rock 0.2.0.0 → 0.3.0.0

raw patch · 9 files changed

+560/−299 lines, 9 filesdep +constraintsdep +constraints-extrasdep +dependent-hashmapdep −containersdep −dependent-mapdep −protoludedep ~basedep ~dependent-sumdep ~deriving-compatPVP ok

version bump matches the API change (PVP)

Dependencies added: constraints, constraints-extras, dependent-hashmap, hashable, hedgehog, lifted-base, monad-control, transformers-base, unordered-containers

Dependencies removed: containers, dependent-map, protolude

Dependency ranges changed: base, dependent-sum, deriving-compat, mtl, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• LICENSE +1/−1
• README.md +27/−37
• examples/Spreadsheet.hs +24/−27
• rock.cabal +49/−11
• src/Rock.hs +1/−1
• src/Rock/Core.hs +213/−202
• src/Rock/Traces.hs +26/−20
• tests/Main.hs +206/−0

@@ -1,5 +1,18 @@ # Unreleased +- Add `memoiseWithCycleDetection` and `Cycle`, enabling cycle detection+- Implement `Task` using `ReaderT`, improving performance+- Make buildable with GHC 8.2.2 through 8.8.3+- Switch from the `dependent-map` package to the `dependent-hashmap` for caches+- Remove support for Haxl-style automatic parallelisation+  * Remove strategy parameter from `runTask`+  * Add `MonadBaseControl`, which allows manual parallelisation using e.g. lifted-async+  * Remove `Sequential` type+- Use `IORef`s instead of `MVar`s+- Add `trackM` function+- Remove `invalidateReverseDependencies` in favour of `reachableReverseDependencies`+- Generalise `verifyTraces` to verify using user-supplied data+ # 0.2.0.0  - Stop using hashes when verifying traces (gets rid of the `Rock.HashTag` and `Rock.Hashed` modules)

@@ -1,4 +1,4 @@-Copyright Olle Fredriksson (c) 2018-2019+Copyright Olle Fredriksson (c) 2018-2020  All rights reserved. 

@@ -1,6 +1,6 @@-# rock [![Hackage](https://img.shields.io/hackage/v/rock.svg)](https://hackage.haskell.org/package/rock)+# rock [![Build Status](https://travis-ci.com/ollef/rock.svg?branch=master)](https://travis-ci.com/ollef/rock) [![Hackage](https://img.shields.io/hackage/v/rock.svg)](https://hackage.haskell.org/package/rock) -A build system inspired by [Build systems à la carte](https://www.microsoft.com/en-us/research/publication/build-systems-la-carte/) and [Haxl](http://hackage.haskell.org/package/haxl).+A build system inspired by [Build systems à la carte](https://www.microsoft.com/en-us/research/publication/build-systems-la-carte/).  Used in [Sixten](https://github.com/ollef/sixten) and [Sixty](https://github.com/ollef/sixty) to achieve incremental and query driven@@ -9,15 +9,16 @@ # Example  ```haskell+{-# language FlexibleInstances #-} {-# language GADTs #-}-{-# language NoImplicitPrelude #-}-{-# language OverloadedStrings #-} {-# language StandaloneDeriving #-} {-# language TemplateHaskell #-} -import Protolude--import Data.GADT.Compare.TH (deriveGEq, deriveGCompare)+import Control.Monad.IO.Class+import Data.GADT.Compare.TH (deriveGEq)+import Data.Hashable+import Data.Some+import Data.IORef import qualified Rock  data Query a where@@ -27,13 +28,22 @@   D :: Query Integer  deriving instance Show (Query a)- deriveGEq ''Query-deriveGCompare ''Query +instance Hashable (Query a) where+  hashWithSalt salt query =+    case query of+      A -> hashWithSalt salt (0 :: Int)+      B -> hashWithSalt salt (1 :: Int)+      C -> hashWithSalt salt (2 :: Int)+      D -> hashWithSalt salt (3 :: Int)++instance Hashable (Some Query) where+  hashWithSalt salt (Some query) = hashWithSalt salt query+ rules :: Rock.Rules Query rules key = do-  putText $ "Fetching " <> show key+  liftIO $ putStrLn $ "Fetching " <> show key   case key of     A -> pure 10     B -> do@@ -48,27 +58,14 @@ main :: IO () main = do   do-    putText "Running"-    result <- Rock.runTask Rock.sequentially rules (Rock.fetch D)-    print result-  do-    putText "Running with memoisation"-    memoVar <- newMVar mempty-    result <--      Rock.runTask-        Rock.sequentially-        (Rock.memoise memoVar rules)-        (Rock.fetch D)+    liftIO $ putStrLn "Running"+    result <- Rock.runTask rules (Rock.fetch D)     print result   do-    putText "Running with memoisation using the parallel strategy"-    memoVar <- newMVar mempty-    result <--      Rock.runTask-        Rock.inParallel-        (Rock.memoise memoVar rules)-        (Rock.fetch D)-    print result+    liftIO $ putStrLn "Running with memoisation"+    memoVar <- newIORef mempty+    result <- Rock.runTask (Rock.memoise memoVar rules) (Rock.fetch D)+    liftIO $ print result ```  Prints@@ -87,12 +84,6 @@ Fetching A Fetching C 70-Running with memoisation using the parallel strategy-Fetching D-Fetching C-Fetching B-Fetching A-70 ```  # Related projects@@ -102,5 +93,4 @@  # Contributions -... are very welcome, especially in the areas of documentation, examples,-testing, and benchmarking.+... are very welcome, especially in the areas of documentation and examples.

@@ -1,12 +1,13 @@+{-# language FlexibleInstances #-} {-# language GADTs #-}-{-# language NoImplicitPrelude #-}-{-# language OverloadedStrings #-} {-# language StandaloneDeriving #-} {-# language TemplateHaskell #-} -import Protolude--import Data.GADT.Compare.TH (deriveGEq, deriveGCompare)+import Control.Monad.IO.Class+import Data.GADT.Compare.TH (deriveGEq)+import Data.Hashable+import Data.Some+import Data.IORef import qualified Rock  data Query a where@@ -16,13 +17,22 @@   D :: Query Integer  deriving instance Show (Query a)- deriveGEq ''Query-deriveGCompare ''Query +instance Hashable (Query a) where+  hashWithSalt salt query =+    case query of+      A -> hashWithSalt salt (0 :: Int)+      B -> hashWithSalt salt (1 :: Int)+      C -> hashWithSalt salt (2 :: Int)+      D -> hashWithSalt salt (3 :: Int)++instance Hashable (Some Query) where+  hashWithSalt salt (Some query) = hashWithSalt salt query+ rules :: Rock.Rules Query rules key = do-  putText $ "Fetching " <> show key+  liftIO $ putStrLn $ "Fetching " <> show key   case key of     A -> pure 10     B -> do@@ -37,24 +47,11 @@ main :: IO () main = do   do-    putText "Running"-    result <- Rock.runTask Rock.sequentially rules (Rock.fetch D)-    print result-  do-    putText "Running with memoisation"-    memoVar <- newMVar mempty-    result <--      Rock.runTask-        Rock.sequentially-        (Rock.memoise memoVar rules)-        (Rock.fetch D)+    liftIO $ putStrLn "Running"+    result <- Rock.runTask rules (Rock.fetch D)     print result   do-    putText "Running with memoisation using the parallel strategy"-    memoVar <- newMVar mempty-    result <--      Rock.runTask-        Rock.inParallel-        (Rock.memoise memoVar rules)-        (Rock.fetch D)-    print result+    liftIO $ putStrLn "Running with memoisation"+    memoVar <- newIORef mempty+    result <- Rock.runTask (Rock.memoise memoVar rules) (Rock.fetch D)+    liftIO $ print result

@@ -1,5 +1,5 @@ name:                rock-version:             0.2.0.0+version:             0.3.0.0 synopsis:            A build system for incremental, parallel, and demand-driven computations description:         See <https://www.github.com/ollef/rock> for more                      information and@@ -10,13 +10,17 @@ license-file:        LICENSE author:              Olle Fredriksson maintainer:          fredriksson.olle@gmail.com-copyright:           2018-2019 Olle Fredriksson+copyright:           2018-2020 Olle Fredriksson category:            Development build-type:          Simple extra-source-files:                      README.md                      CHANGELOG.md cabal-version:       >=1.10+tested-with:         GHC == 8.2.2+                   , GHC == 8.4.3+                   , GHC == 8.6.5+                   , GHC == 8.8.3  library   ghc-options:         -Wall@@ -35,15 +39,19 @@                        Rock.Core                        Rock.Traces   build-depends:       base >= 4.7 && < 5-                     , containers-                     , dependent-map-                     , dependent-sum-                     , deriving-compat-                     , mtl-                     , transformers-                     , protolude+                     , constraints-extras >= 0.3+                     , dependent-hashmap >= 0.1+                     , dependent-sum >= 0.6+                     , deriving-compat >= 0.5+                     , hashable >= 1.3+                     , lifted-base >= 0.2+                     , monad-control >= 1.0+                     , mtl >= 2.2+                     , transformers >= 0.5+                     , transformers-base >= 0.4+                     , unordered-containers >= 0.2   default-language:    Haskell2010-  default-extensions:  OverloadedStrings, NoImplicitPrelude+  default-extensions:  OverloadedStrings  source-repository head   type:     git@@ -62,4 +70,34 @@                        -threaded   hs-source-dirs:      examples   default-language:    Haskell2010-  build-depends:       base, rock, protolude, dependent-sum-template+  build-depends:       base+                     , dependent-sum+                     , dependent-sum-template+                     , hashable+                     , rock++test-suite test-rock+  type:                exitcode-stdio-1.0+  main-is:             Main.hs+  hs-source-dirs:      tests+  ghc-options:         -Wall+                       -Wcompat+                       -Widentities+                       -Wincomplete-record-updates+                       -Wincomplete-uni-patterns+                       -Wmissing-home-modules+                       -Wpartial-fields+                       -Wredundant-constraints+                       -Wtabs+                       -funbox-strict-fields+  build-depends:       base >=4.7 && <5+                     , constraints+                     , constraints-extras+                     , dependent-hashmap+                     , dependent-sum+                     , hashable+                     , hedgehog+                     , mtl+                     , rock+                     , unordered-containers+  default-language:  Haskell2010

@@ -3,5 +3,5 @@   , Traces   ) where -import Rock.Core+import Rock.Core hiding (Fetch) import Rock.Traces

@@ -1,6 +1,5 @@ {-# language CPP #-} {-# language DefaultSignatures #-}-{-# language DeriveFunctor #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language FunctionalDependencies #-}@@ -8,30 +7,46 @@ {-# language GeneralizedNewtypeDeriving #-} {-# language RankNTypes #-} {-# language ScopedTypeVariables #-}+{-# language TupleSections #-}+{-# language TypeFamilies #-} {-# language UndecidableInstances #-} module Rock.Core where -#if MIN_VERSION_base(4,12,0)-import Protolude hiding (Ap)-#else-import Protolude-#endif-+import Control.Concurrent+import Control.Exception.Lifted+import Control.Monad.Base import Control.Monad.Cont+import Control.Monad.Except import Control.Monad.Identity+import Control.Monad.Reader import qualified Control.Monad.RWS.Lazy as Lazy import qualified Control.Monad.RWS.Strict as Strict import qualified Control.Monad.State.Lazy as Lazy import qualified Control.Monad.State.Strict as Strict+import Control.Monad.Trans.Control import Control.Monad.Trans.Maybe import qualified Control.Monad.Writer.Lazy as Lazy import qualified Control.Monad.Writer.Strict as Strict-import Data.Dependent.Map(DMap, GCompare)-import qualified Data.Dependent.Map as DMap+import Data.Bifunctor+import Data.Constraint.Extras+import Data.Dependent.HashMap (DHashMap)+import qualified Data.Dependent.HashMap as DHashMap import Data.Dependent.Sum-import Data.GADT.Compare-import qualified Data.Map as Map-import qualified Data.Set as Set+import Data.Foldable+import Data.Functor.Const+import Data.GADT.Compare (GEq, GCompare, geq, gcompare, GOrdering(..))+import Data.GADT.Show (GShow)+import Data.Hashable+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import Data.IORef+import Data.Maybe+import Data.Typeable+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#endif import Data.Some  import Rock.Traces(Traces)@@ -50,20 +65,11 @@  -- | An @IO@ action that is allowed to make @f@ queries using the 'fetch' -- method from its 'MonadFetch' instance.-newtype Task f a = Task { unTask :: IO (Result f a) }---- | The result of a @Task@, which is either done or wanting to make one or--- more @f@ queries.-data Result f a-  = Done a-  | Blocked !(BlockedTask f a)--data BlockedTask f a where-  BlockedTask :: Block f a -> (a -> Task f b) -> BlockedTask f b+newtype Task f a = Task { unTask :: ReaderT (Fetch f) IO a }+  deriving+    (Functor, Applicative, Monad, MonadIO, MonadBase IO) -data Block f a where-  Fetch :: f a -> Block f a-  Ap :: !(BlockedTask f (a -> b)) -> !(BlockedTask f a) -> Block f b+newtype Fetch f = Fetch (forall a. f a -> IO a)  ------------------------------------------------------------------------------- -- * Fetch class@@ -92,60 +98,16 @@ ------------------------------------------------------------------------------- -- Instances -instance Functor (Task f) where-  {-# INLINE fmap #-}-  fmap f (Task t) = Task $ fmap f <$> t---- Note: This instance might not fully evaluate @t1@ before @t2@ in--- @t1 '<*>' t2@ in case @t1@ performs a query using 'fetch'. If this--- is not desirable, use 'Sequential'.-instance Applicative (Task f) where-  {-# INLINE pure #-}-  pure = Task . pure . Done-  {-# INLINE (<*>) #-}-  Task mrf <*> Task mrx = Task $ (<*>) <$> mrf <*> mrx--instance Monad (Task f) where-  {-# INLINE (>>) #-}-  (>>) = (*>)-  {-# INLINE (>>=) #-}-  Task ma >>= f = Task $ do-    ra <- ma-    case ra of-      Done a -> unTask $ f a-      Blocked (BlockedTask b k) -> return $ Blocked $ BlockedTask b $ k >=> f--instance MonadIO (Task f) where-  {-# INLINE liftIO #-}-  liftIO io = Task $ pure <$> io- instance MonadFetch f (Task f) where-  fetch key = Task $ pure $ Blocked $ BlockedTask (Fetch key) pure--instance Functor (Result f) where-  {-# INLINE fmap #-}-  fmap f (Done x) = Done $ f x-  fmap f (Blocked b) = Blocked $ f <$> b--instance Applicative (Result f) where-  {-# INLINE pure #-}-  pure = Done-  {-# INLINE (<*>) #-}-  Done f <*> Done x = Done $ f x-  Done f <*> Blocked b = Blocked $ f <$> b-  Blocked b <*> Done x = Blocked $ ($ x) <$> b-  Blocked b1 <*> Blocked b2 = Blocked $ BlockedTask (Ap b1 b2) pure--instance Monad (Result f) where-  {-# INLINE (>>) #-}-  (>>) = (*>)-  {-# INLINE (>>=) #-}-  Done x >>= f = f x-  Blocked (BlockedTask b t) >>= f = Blocked $ BlockedTask b $ t >=> Task . pure . f+  {-# INLINE fetch #-}+  fetch key = Task $ do+    io <- asks (\(Fetch fetch_) -> fetch_ key)+    liftIO io -instance Functor (BlockedTask f) where-  {-# INLINE fmap #-}-  fmap f (BlockedTask b t) = BlockedTask b $ fmap f <$> t+instance MonadBaseControl IO (Task f) where+  type StM (Task f) a = StM (ReaderT (Fetch f) IO) a+  liftBaseWith k = Task $ liftBaseWith $ \ma -> k $ ma . unTask+  restoreM = Task . restoreM  ------------------------------------------------------------------------------- -- * Transformations@@ -155,151 +117,201 @@   :: (forall b. f b -> Task f' b)   -> Task f a   -> Task f' a-transFetch f task = Task $ do-  result <- unTask task-  case result of-    Done a -> return $ Done a-    Blocked b -> unTask $ transFetchBlockedTask f b--transFetchBlockedTask-  :: (forall b. f b -> Task f' b)-  -> BlockedTask f a-  -> Task f' a-transFetchBlockedTask f (BlockedTask b t) = do-  a <- transFetchBlock f b-  transFetch f $ t a--transFetchBlock-  :: (forall b. f b -> Task f' b)-  -> Block f a-  -> Task f' a-transFetchBlock f (Fetch k) = f k-transFetchBlock f (Ap b1 b2) = transFetchBlockedTask f b1 <*> transFetchBlockedTask f b2------------------------------------------------------------------------------------ * Strategies---- | A 'Strategy' specifies how two queries are performed in an 'Applicative'--- context.-type Strategy = forall a b. IO (a -> b) -> IO a -> IO b---- | Runs the two queries in sequence.-sequentially :: Strategy-sequentially = (<*>)---- | Runs the two queries in parallel.-inParallel :: Strategy-inParallel mf mx = withAsync mf $ \af -> do-  x <- mx-  f <- wait af-  return $ f x---- | Uses the underlying instances, except for the Applicative instance which--- is defined in terms of 'return' and '(>>=)'.------ When used with 'Task', i.e. if you construct @m :: 'Sequential' ('Task' f)--- a@, this means that fetches within @m@ are done sequentially.-newtype Sequential m a = Sequential { runSequential :: m a }-  deriving (Functor, Monad, MonadIO, MonadFetch f)---- | Defined in terms of 'return' and '(>>=)'.-instance Monad m => Applicative (Sequential m) where-  {-# INLINE pure #-}-  pure = Sequential . return-  {-# INLINE (<*>) #-}-  Sequential mf <*> Sequential mx = Sequential $ mf >>= \f -> fmap f mx+transFetch f (Task task) =+  Task $ ReaderT $ \fetch_ ->+    runReaderT task $ Fetch $ \key ->+      runReaderT (unTask $ f key) fetch_  ------------------------------------------------------------------------------- -- * Running tasks --- | Perform a 'Task', fetching dependency queries from the given 'Rules' function and using the given 'Strategy' for fetches in an 'Applicative' context.-runTask :: Strategy -> Rules f -> Task f a -> IO a-runTask strategy rules task = do-  result <- unTask task-  case result of-    Done a -> return a-    Blocked b -> runBlockedTask strategy rules b--runBlockedTask :: Strategy -> Rules f -> BlockedTask f a -> IO a-runBlockedTask strategy rules (BlockedTask b f) = do-  a <- runBlock strategy rules b-  runTask strategy rules $ f a--runBlock :: Strategy -> Rules f -> Block f a -> IO a-runBlock strategy rules (Fetch key) =-  runTask strategy rules $ rules key-runBlock strategy rules (Ap bf bx) =-  strategy (runBlockedTask strategy rules bf) (runBlockedTask strategy rules bx)+-- | Perform a 'Task', fetching dependency queries from the given 'Rules'+-- function.+runTask :: Rules f -> Task f a -> IO a+runTask rules (Task task) =+  runReaderT task $ Fetch $ runTask rules . rules  ------------------------------------------------------------------------------- -- * Task combinators --- | Track the query dependencies of a 'Task' in a 'DMap'-track :: forall f a. GCompare f => Task f a -> Task f (a, DMap f Identity)-track task = do-  depsVar <- liftIO $ newMVar mempty+-- | Track the query dependencies of a 'Task' in a 'DHashMap'.+track+  :: forall f g a. (GEq f, Hashable (Some f))+  => (forall a'. f a' -> a' -> g a')+  -> Task f a+  -> Task f (a, DHashMap f g)+track f =+  trackM $ \key -> pure . f key++-- | Track the query dependencies of a 'Task' in a 'DHashMap'. Monadic version.+trackM+  :: forall f g a. (GEq f, Hashable (Some f))+  => (forall a'. f a' -> a' -> Task f (g a'))+  -> Task f a+  -> Task f (a, DHashMap f g)+trackM f task = do+  depsVar <- liftIO $ newIORef mempty   let     record :: f b -> Task f b     record key = do       value <- fetch key-      liftIO $ modifyMVar_ depsVar $ pure . DMap.insert key (Identity value)+      g <- f key value+      liftIO $ atomicModifyIORef depsVar $ (, ()) . DHashMap.insert key g       return value   result <- transFetch record task-  deps <- liftIO $ readMVar depsVar+  deps <- liftIO $ readIORef depsVar   return (result, deps)  -- | Remember what @f@ queries have already been performed and their results in--- a 'DMap', and reuse them if a query is performed again a second time.+-- a 'DHashMap', and reuse them if a query is performed again a second time. ----- The 'DMap' should typically not be reused if there has been some change that+-- The 'DHashMap' should typically not be reused if there has been some change that -- might make a query return a different result. memoise   :: forall f g-  . GCompare f-  => MVar (DMap f MVar)+  . (GEq f, Hashable (Some f))+  => IORef (DHashMap f MVar)   -> GenRules f g   -> GenRules f g-memoise startedVar rules (key :: f a) =-  join $ liftIO $ modifyMVar startedVar $ \started ->-    case DMap.lookup key started of-      Nothing -> do-        valueVar <- newEmptyMVar-        return-          ( DMap.insert key valueVar started-          , do-            value <- rules key-            liftIO $ putMVar valueVar value-            return value-          )-      Just valueVar ->-        return (started, liftIO $ readMVar valueVar)+memoise startedVar rules (key :: f a) = do+  maybeValueVar <- DHashMap.lookup key <$> liftIO (readIORef startedVar)+  case maybeValueVar of+    Nothing -> do+      valueVar <- liftIO newEmptyMVar+      join $ liftIO $ atomicModifyIORef startedVar $ \started ->+        case DHashMap.alterLookup (Just . fromMaybe valueVar) key started of+          (Nothing, started') ->+            ( started'+            , do+              value <- rules key+              liftIO $ putMVar valueVar value+              return value+            ) +          (Just valueVar', _started') ->+            (started, liftIO $ readMVar valueVar')++    Just valueVar ->+      liftIO $ readMVar valueVar++newtype Cyclic f = Cyclic (Some f)+  deriving Show++instance (GShow f, Typeable f) => Exception (Cyclic f)++data MemoEntry a+  = Started !ThreadId !(MVar (Maybe a))+  | Done !a++-- | Like 'memoise', but throw @'Cyclic' f@ if a query depends on itself, directly or+-- indirectly.+--+-- The 'HashMap' represents dependencies between threads and should not be+-- reused between invocations.+memoiseWithCycleDetection+  :: forall f g+  . (Typeable f, GShow f, GEq f, Hashable (Some f))+  => IORef (DHashMap f MemoEntry)+  -> IORef (HashMap ThreadId ThreadId)+  -> GenRules f g+  -> GenRules f g+memoiseWithCycleDetection startedVar depsVar rules =+  rules'+  where+    rules' (key :: f a) = do+      maybeEntry <- DHashMap.lookup key <$> liftIO (readIORef startedVar)+      case maybeEntry of+        Nothing -> do+          threadId <- liftIO myThreadId+          valueVar <- liftIO newEmptyMVar+          join $ liftIO $ atomicModifyIORef startedVar $ \started ->+            case DHashMap.alterLookup (Just . fromMaybe (Started threadId valueVar)) key started of+              (Nothing, started') ->+                ( started'+                , (do+                    value <- rules key+                    liftIO $ do+                      atomicModifyIORef startedVar $ \started'' ->+                        (DHashMap.insert key (Done value) started'', ())+                      putMVar valueVar $ Just value+                      return value+                  ) `catch` \(e :: Cyclic f) ->+                  (liftIO $ do+                    atomicModifyIORef startedVar $ \started'' ->+                      (DHashMap.delete key started'', ())+                    putMVar valueVar Nothing+                    throwIO e+                  )+                )++              (Just entry, _started') ->+                (started, waitFor entry)++        Just entry ->+          waitFor entry+      where+        waitFor entry =+          case entry of+            Started onThread valueVar -> do+              threadId <- liftIO myThreadId+              join $ liftIO $ atomicModifyIORef depsVar $ \deps -> do+                let+                  deps' =+                    HashMap.insert threadId onThread deps++                if detectCycle threadId deps' then+                  ( deps+                  , throwIO $ Cyclic $ Some key+                  )+                else+                  ( deps'+                  , do+                    maybeValue <- liftIO $ readMVar valueVar+                    liftIO $ atomicModifyIORef depsVar $ \deps'' -> (HashMap.delete threadId deps'', ())+                    maybe (rules' key) return maybeValue+                  )++            Done value ->+              return value++    detectCycle threadId deps =+      go threadId+      where+        go tid =+          case HashMap.lookup tid deps of+            Nothing -> False+            Just dep+              | dep == threadId -> True+              | otherwise -> go dep+ -- | Remember the results of previous @f@ queries and what their dependencies -- were then. -- -- If all dependencies of a 'NonInput' query are the same, reuse the old result. -- 'Input' queries are not reused. verifyTraces-  :: (EqTag f Identity, GCompare f)-  => MVar (Traces f)+  :: forall f dep+  . (Hashable (Some f), GEq f, Has' Eq f dep, Typeable f, GShow f)+  => IORef (Traces f dep)+  -> (forall a. f a -> a -> Task f (dep a))   -> GenRules (Writer TaskKind f) f   -> Rules f-verifyTraces tracesVar rules key = do-  traces <- liftIO $ readMVar tracesVar-  maybeValue <- case DMap.lookup key traces of+verifyTraces tracesVar createDependencyRecord rules key = do+  traces <- liftIO $ readIORef tracesVar+  maybeValue <- case DHashMap.lookup key traces of     Nothing -> return Nothing     Just oldValueDeps ->-      Traces.verifyDependencies fetch oldValueDeps+      Traces.verifyDependencies fetch createDependencyRecord oldValueDeps `catch` \(_ :: Cyclic f) ->+        pure Nothing   case maybeValue of     Nothing -> do-      ((value, taskKind), deps) <- track $ rules $ Writer key+      ((value, taskKind), deps) <- trackM createDependencyRecord $ rules $ Writer key       case taskKind of         Input ->           return ()         NonInput ->-          liftIO $ modifyMVar_ tracesVar-            $ pure-            . Traces.record key value deps+          liftIO $ atomicModifyIORef tracesVar+            $ (, ()) . Traces.record key value deps       return value     Just value -> return value @@ -348,35 +360,34 @@   after key result   return result -type ReverseDependencies f = Map (Some f) (Set (Some f))+type ReverseDependencies f = HashMap (Some f) (HashSet (Some f)) --- | Write reverse dependencies to the 'MVar'.+-- | Write reverse dependencies to the 'IORef. trackReverseDependencies-  :: GCompare f-  => MVar (ReverseDependencies f)+  :: (GEq f, Hashable (Some f))+  => IORef (ReverseDependencies f)   -> Rules f   -> Rules f trackReverseDependencies reverseDepsVar rules key = do-  (res, deps) <- track $ rules key-  unless (DMap.null deps) $ do-    let newReverseDeps = Map.fromListWith (<>)-          [ (This depKey, Set.singleton $ This key)-          | depKey DMap.:=> _ <- DMap.toList deps+  (res, deps) <- track (\_ _ -> Const ()) $ rules key+  unless (DHashMap.null deps) $ do+    let newReverseDeps = HashMap.fromListWith (<>)+          [ (Some depKey, HashSet.singleton $ Some key)+          | depKey :=> Const () <- DHashMap.toList deps           ]-    liftIO $ modifyMVar_ reverseDepsVar $ pure . Map.unionWith (<>) newReverseDeps+    liftIO $ atomicModifyIORef reverseDepsVar $ (, ()) . HashMap.unionWith (<>) newReverseDeps   pure res --- | @'invalidateReverseDependencies' key@ removes all keys reachable, by--- reverse dependency, from @key@ from the input 'DMap'. It also returns the+-- | @'reachableReverseDependencies' key@ returns all keys reachable, by+-- reverse dependency, from @key@ from the input 'DHashMap'. It also returns the -- reverse dependency map with those same keys removed.-invalidateReverseDependencies-  :: GCompare f+reachableReverseDependencies+  :: (GEq f, Hashable (Some f))   => f a   -> ReverseDependencies f-  -> DMap f g-  -> (ReverseDependencies f, DMap f g)-invalidateReverseDependencies key reverseDeps m =+  -> (DHashMap f (Const ()), ReverseDependencies f)+reachableReverseDependencies key reverseDeps =   foldl'-    (\(reverseDeps', m') (This key') -> invalidateReverseDependencies key' reverseDeps' m')-    (Map.delete (This key) reverseDeps, DMap.delete key m)-    (Set.toList $ Map.findWithDefault mempty (This key) reverseDeps)+    (\(m', reverseDeps') (Some key') -> first (<> m') $ reachableReverseDependencies key' reverseDeps')+    (DHashMap.singleton key $ Const (), HashMap.delete (Some key) reverseDeps)+    (HashSet.toList $ HashMap.lookupDefault mempty (Some key) reverseDeps)

@@ -5,37 +5,43 @@ {-# language UndecidableInstances #-} module Rock.Traces where -import Protolude--import Data.Dependent.Map(DMap, GCompare, DSum((:=>)))-import qualified Data.Dependent.Map as DMap+import Control.Monad.IO.Class+import Data.Constraint.Extras+import Data.Dependent.HashMap(DHashMap)+import qualified Data.Dependent.HashMap as DHashMap import Data.Dependent.Sum import Data.Functor.Classes+import Data.GADT.Compare+import Data.GADT.Show+import Data.Hashable+import Data.Some import Text.Show.Deriving -data ValueDeps f a = ValueDeps+data ValueDeps f dep a = ValueDeps   { value :: !a-  , dependencies :: !(DMap f Identity)+  , dependencies :: !(DHashMap f dep)   }  return [] -deriving instance (ShowTag f Identity, Show a) => Show (ValueDeps f a)+deriving instance (Show a, GShow f, Has' Show f dep) => Show (ValueDeps f dep a) -instance ShowTag f Identity => Show1 (ValueDeps f) where+instance (GShow f, Has' Show f dep) => Show1 (ValueDeps f dep) where   liftShowsPrec = $(makeLiftShowsPrec ''ValueDeps) -type Traces f = DMap f (ValueDeps f)+type Traces f dep = DHashMap f (ValueDeps f dep)  verifyDependencies-  :: (Monad m, EqTag f Identity)+  :: (MonadIO m, GEq f, Has' Eq f dep)   => (forall a'. f a' -> m a')-  -> ValueDeps f a+  -> (forall a'. f a' -> a' -> m (dep a'))+  -> ValueDeps f dep a   -> m (Maybe a)-verifyDependencies fetch (ValueDeps value_ deps) = do-  upToDate <- allM (DMap.toList deps) $ \(depKey :=> depValue) -> do-    depValue' <- fetch depKey-    return $ eqTagged depKey depKey depValue $ Identity depValue'+verifyDependencies fetch createDependencyRecord (ValueDeps value_ deps) = do+  upToDate <- allM (DHashMap.toList deps) $ \(depKey :=> dep) -> do+    depValue <- fetch depKey+    newDep <- createDependencyRecord depKey depValue+    return $ eqTagged depKey depKey dep newDep   return $ if upToDate     then Just value_     else Nothing@@ -50,12 +56,12 @@         return False  record-  :: GCompare f+  :: (GEq f, Hashable (Some f))   => f a   -> a-  -> DMap f Identity-  -> Traces f-  -> Traces f+  -> DHashMap f g+  -> Traces f g+  -> Traces f g record k v deps-  = DMap.insert k+  = DHashMap.insert k   $ ValueDeps v deps

@@ -0,0 +1,206 @@+{-# language CPP #-}+{-# language FlexibleInstances #-}+{-# language GADTs #-}+{-# language MultiParamTypeClasses #-}+{-# language RankNTypes #-}+{-# language StandaloneDeriving #-}+{-# language TypeApplications #-}+{-# language TemplateHaskell #-}+{-# language TypeFamilies #-}+module Main where++import Control.Monad+import Control.Monad.Identity+import Control.Monad.IO.Class+import Data.Constraint.Extras+import Data.Constraint.Extras.TH+import qualified Data.Dependent.HashMap as DHashMap+import Data.Functor.Const+import Data.GADT.Compare+import Data.GADT.Show+import Data.Hashable+import Data.IORef+import Data.List+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#endif+import Data.Some+import Data.Type.Equality ((:~:)(Refl))+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Rock++data Key v where+  IntKey :: Int -> Key Int+  StringKey :: String -> Key String++deriving instance Show (Key v)++instance GShow Key where+  gshowsPrec = showsPrec++instance GShow (Writer w Key) where+  gshowsPrec d (Writer key) = showsPrec d key++instance Hashable (Some Key) where+  hashWithSalt salt (Some key) =+    case key of+      IntKey i -> hashWithSalt salt (0 :: Int, i)+      StringKey s -> hashWithSalt salt (1 :: Int, s)++deriveArgDict ''Key++instance GEq Key where+  geq (IntKey i1) (IntKey i2)+    | i1 == i2 =+      Just Refl+  geq (StringKey s1) (StringKey s2)+    | s1 == s2 =+      Just Refl+  geq _ _ =+    Nothing++instance GCompare Key where+  gcompare (IntKey i1) (IntKey i2)+    | i1 == i2 =+      GEQ+    | i1 < i2 =+      GLT+    | otherwise =+      GGT+  gcompare (IntKey _) _ =+    GLT+  gcompare _ (IntKey _) =+    GGT+  gcompare (StringKey s1) (StringKey s2)+    | s1 == s2 =+      GEQ+    | s1 < s2 =+      GLT+    | otherwise =+      GGT++int :: Gen Int+int = Gen.int (Range.linear 0 100)++string :: Gen String+string = Gen.string (Range.linear 0 100) Gen.ascii++key :: Gen (Some Key)+key =+  Gen.choice+    [ Some . IntKey <$> int+    , Some . StringKey <$> string+    ]++addRules :: Rules Key+addRules key_ =+  case key_ of+    IntKey i ->+      pure $ i + 1++    StringKey s ->+      pure $ s <> "a"++withKeyFetchedCallback :: (Some f -> IO ()) -> GenRules f g -> GenRules f g+withKeyFetchedCallback keyFetched rules key_ = do+  liftIO $ keyFetched $ Some key_+  rules key_++prop_track_tracks :: Property+prop_track_tracks =+  property $ do+    Some key_ <- forAll key+    startedVar <- liftIO $ newIORef mempty+    let+      rules :: Rules Key+      rules =+        memoise startedVar addRules++    ((), deps) <- liftIO $ runTask rules $ do+      void $ fetch key_+      track (\_ _ -> Const ()) $ void $ fetch key_++    DHashMap.keys deps === [Some key_]++prop_memoise_memoises :: Property+prop_memoise_memoises =+  property $ do+    Some key_ <- forAll key+    fetchedKeysVar <- liftIO $ newIORef []+    startedVar <- liftIO $ newIORef mempty+    let+      keyFetched k =+        atomicModifyIORef fetchedKeysVar $ \ks -> (k : ks, ())++      rules :: Rules Key+      rules =+        memoise startedVar (withKeyFetchedCallback keyFetched addRules)++    liftIO $ runTask rules $ do+      void $ fetch key_+      void $ fetch key_++    fetchedKeys <- liftIO $ readIORef fetchedKeysVar+    fetchedKeys === [Some key_]++inputRules :: Int -> GenRules (Writer TaskKind Key) Key+inputRules input (Writer key_) =+  case key_ of+    IntKey 0 -> do+      pure (input, Input)++    IntKey i -> do+      pure (i + 1, NonInput)++    StringKey "dependent" -> do+      i <- fetch $ IntKey 0+      j <- fetch $ IntKey 1+      pure (show i <> show j, NonInput)++    StringKey s -> do+      i <- fetch $ IntKey 1+      j <- fetch $ IntKey 2+      pure (s <> show i <> show j, NonInput)++prop_verifyTraces :: Property+prop_verifyTraces =+  property $ do+    fetchedKeysVar <- liftIO $ newIORef []+    startedVar <- liftIO $ newIORef mempty+    tracesVar <- liftIO $ newIORef mempty+    let+      keyFetched k =+        atomicModifyIORef fetchedKeysVar $ \ks -> (k : ks, ())++      rules :: Int -> Rules Key+      rules input =+        memoise startedVar $+        verifyTraces+          tracesVar+          (\query value ->+            pure $ Const $ has' @Hashable @Identity query $ hash $ Identity value+          ) $+        withKeyFetchedCallback keyFetched $+        inputRules input++    nonDependentKey <- forAll $ Gen.filter (/= "dependent") string++    liftIO $ runTask (rules 1) $ do+      void $ fetch $ StringKey "dependent"+      void $ fetch $ StringKey nonDependentKey++    liftIO $ atomicWriteIORef startedVar mempty+    liftIO $ atomicWriteIORef fetchedKeysVar mempty++    liftIO $ runTask (rules 2) $ do+      void $ fetch $ StringKey "dependent"+      void $ fetch $ StringKey nonDependentKey++    fetchedKeys <- liftIO $ readIORef fetchedKeysVar+    sort fetchedKeys === [Some $ Writer $ IntKey 0, Some $ Writer $ StringKey "dependent"]++main :: IO ()+main =+  void $ checkParallel $$(discover)