rock (empty) → 0.1.0.0

raw patch · 11 files changed

+736/−0 lines, 11 filesdep +basedep +dependent-mapdep +dependent-sumsetup-changed

Dependencies added: base, dependent-map, dependent-sum, dependent-sum-template, deriving-compat, mtl, protolude, rock, transformers

Files

CHANGELOG.md +5/−0
LICENSE +30/−0
README.md +106/−0
Setup.hs +2/−0
examples/Spreadsheet.hs +60/−0
rock.cabal +66/−0
src/Rock.hs +9/−0
src/Rock/Core.hs +345/−0
src/Rock/HashTag.hs +19/−0
src/Rock/Hashed.hs +30/−0
src/Rock/Traces.hs +64/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Unreleased++# 0.1.0.0++- Initial release

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Olle Fredriksson (c) 2018-2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Olle Fredriksson nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,106 @@+# 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).++Used in [Sixten](https://github.com/ollef/sixten) and+[Sixty](https://github.com/ollef/sixty) to achieve incremental and query driven+compiler architectures.++# Example++```haskell+{-# language GADTs #-}+{-# language NoImplicitPrelude #-}+{-# language OverloadedStrings #-}+{-# language StandaloneDeriving #-}+{-# language TemplateHaskell #-}++import Protolude++import Data.GADT.Compare.TH (deriveGEq, deriveGCompare)+import qualified Rock++data Query a where+  A :: Query Integer+  B :: Query Integer+  C :: Query Integer+  D :: Query Integer++deriving instance Show (Query a)++deriveGEq ''Query+deriveGCompare ''Query++rules :: Rock.Rules Query+rules key = do+  putText $ "Fetching " <> show key+  case key of+    A -> pure 10+    B -> do+      a <- Rock.fetch A+      pure $ a + 20+    C -> do+      a <- Rock.fetch A+      pure $ a + 30+    D ->+      (+) <$> Rock.fetch B <*> Rock.fetch C++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)+    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+```++Prints++```+Running+Fetching D+Fetching B+Fetching A+Fetching C+Fetching A+70+Running with memoisation+Fetching D+Fetching B+Fetching A+Fetching C+70+Running with memoisation using the parallel strategy+Fetching D+Fetching C+Fetching B+Fetching A+70+```++# Related projects++* [Shake](http://hackage.haskell.org/package/shake)+* [Salsa](https://crates.io/crates/salsa)++# Contributions++... are very welcome, especially in the areas of documentation, examples,+testing, and benchmarking.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ examples/Spreadsheet.hs view

@@ -0,0 +1,60 @@+{-# language GADTs #-}+{-# language NoImplicitPrelude #-}+{-# language OverloadedStrings #-}+{-# language StandaloneDeriving #-}+{-# language TemplateHaskell #-}++import Protolude++import Data.GADT.Compare.TH (deriveGEq, deriveGCompare)+import qualified Rock++data Query a where+  A :: Query Integer+  B :: Query Integer+  C :: Query Integer+  D :: Query Integer++deriving instance Show (Query a)++deriveGEq ''Query+deriveGCompare ''Query++rules :: Rock.Rules Query+rules key = do+  putText $ "Fetching " <> show key+  case key of+    A -> pure 10+    B -> do+      a <- Rock.fetch A+      pure $ a + 20+    C -> do+      a <- Rock.fetch A+      pure $ a + 30+    D ->+      (+) <$> Rock.fetch B <*> Rock.fetch C++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)+    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

+ rock.cabal view

@@ -0,0 +1,66 @@+name:                rock+version:             0.1.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+                     <https://github.com/ollef/rock/tree/master/examples> for+                     examples.+homepage:            https://github.com/ollef/rock#readme+license:             BSD3+license-file:        LICENSE+author:              Olle Fredriksson+maintainer:          fredriksson.olle@gmail.com+copyright:           2018-2019 Olle Fredriksson+category:            Development+build-type:          Simple+extra-source-files:+                     README.md+                     CHANGELOG.md+cabal-version:       >=1.10++library+  ghc-options:         -Wall+                       -Wcompat+                       -Widentities+                       -Wincomplete-record-updates+                       -Wincomplete-uni-patterns+                       -Wmissing-home-modules+                       -Wpartial-fields+                       -Wredundant-constraints+                       -Wtabs+                       -funbox-strict-fields+  hs-source-dirs:      src+  exposed-modules:+                       Rock+                       Rock.Core+                       Rock.HashTag+                       Rock.Hashed+                       Rock.Traces+  build-depends:       base >= 4.7 && < 5+                     , dependent-map+                     , dependent-sum+                     , deriving-compat+                     , mtl+                     , transformers+                     , protolude+  default-language:    Haskell2010+  default-extensions:  OverloadedStrings, NoImplicitPrelude++source-repository head+  type:     git+  location: https://github.com/ollef/rock++flag examples+  Description: "Build examples"+  Default:     False+  Manual:      True++executable rock-spreadsheet+  if !flag(examples)+    buildable:         False+  main-is:             Spreadsheet.hs+  ghc-options:         -Wall+                       -threaded+  hs-source-dirs:      examples+  default-language:    Haskell2010+  build-depends:       base, rock, protolude, dependent-sum-template

+ src/Rock.hs view

@@ -0,0 +1,9 @@+module Rock+  ( module Rock.Core+  , module Rock.HashTag+  , Traces+  ) where++import Rock.Core+import Rock.HashTag+import Rock.Traces

+ src/Rock/Core.hs view

@@ -0,0 +1,345 @@+{-# language DefaultSignatures #-}+{-# language DeriveFunctor #-}+{-# language FlexibleInstances #-}+{-# language FunctionalDependencies #-}+{-# language GADTs #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language MultiParamTypeClasses #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language UndecidableInstances #-}+module Rock.Core where++import Protolude++import Control.Monad.Cont+import Control.Monad.Identity+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.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.GADT.Compare++import Rock.Hashed+import Rock.HashTag+import Rock.Traces(Traces)+import qualified Rock.Traces as Traces++-------------------------------------------------------------------------------+-- * Types++-- | A function which, given an @f@ query, returns a 'Task' allowed to make @f@+-- queries to compute its result.+type Rules f = GenRules f f++-- | A function which, given an @f@ query, returns a 'Task' allowed to make @g@+-- queries to compute its result.+type GenRules f g = forall a. f a -> Task g a++-- | 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++data Block f a where+  Fetch :: f a -> Block f a+  Ap :: !(BlockedTask f (a -> b)) -> !(BlockedTask f a) -> Block f b++-------------------------------------------------------------------------------+-- * Fetch class++-- | Monads that can make @f@ queries by 'fetch'ing them.+class Monad m => MonadFetch f m | m -> f where+  fetch :: f a -> m a+  default fetch+    :: (MonadTrans t, MonadFetch f m1, m ~ t m1)+    => f a+    -> m a+  fetch = lift . fetch++instance MonadFetch f m => MonadFetch f (ContT r m)+instance MonadFetch f m => MonadFetch f (ExceptT e m)+instance MonadFetch f m => MonadFetch f (IdentityT m)+instance MonadFetch f m => MonadFetch f (MaybeT m)+instance MonadFetch f m => MonadFetch f (ReaderT r m)+instance (MonadFetch f m, Monoid w) => MonadFetch f (Strict.RWST r w s m)+instance (MonadFetch f m, Monoid w) => MonadFetch f (Lazy.RWST r w s m)+instance MonadFetch f m => MonadFetch f (Strict.StateT s m)+instance MonadFetch f m => MonadFetch f (Lazy.StateT s m)+instance (Monoid w, MonadFetch f m) => MonadFetch f (Strict.WriterT w m)+instance (Monoid w, MonadFetch f m) => MonadFetch f (Lazy.WriterT w m)++-------------------------------------------------------------------------------+-- 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++instance Functor (BlockedTask f) where+  {-# INLINE fmap #-}+  fmap f (BlockedTask b t) = BlockedTask b $ fmap f <$> t++-------------------------------------------------------------------------------+-- * Transformations++-- | Transform the type of queries that a 'Task' performs.+transFetch+  :: (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++-------------------------------------------------------------------------------+-- * 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)++-------------------------------------------------------------------------------+-- * 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+  let+    record :: f b -> Task f b+    record key = do+      value <- fetch key+      liftIO $ modifyMVar_ depsVar $ pure . DMap.insert key (Identity value)+      return value+  result <- transFetch record task+  deps <- liftIO $ readMVar 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.+--+-- The 'DMap' 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)+  -> 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)++-- | 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.+-- The 'DMap' _can_ be reused if there are changes to 'Input' queries.+verifyTraces+  :: (GCompare f, HashTag f)+  => MVar (Traces f)+  -> GenRules (Writer TaskKind f) f+  -> Rules f+verifyTraces tracesVar rules key = do+  traces <- liftIO $ readMVar tracesVar+  maybeValue <- case DMap.lookup key traces of+    Nothing -> return Nothing+    Just oldValueDeps ->+      Traces.verifyDependencies fetchHashed oldValueDeps+  case maybeValue of+    Nothing -> do+      ((value, taskKind), deps) <- track $ rules $ Writer key+      case taskKind of+        Input ->+          return ()+        NonInput ->+          liftIO $ modifyMVar_ tracesVar+            $ pure+            . Traces.record key value deps+      return value+    Just value -> return value+  where+    fetchHashed :: HashTag f => f a -> Task f (Hashed a)+    fetchHashed key' = hashed key' <$> fetch key'++data TaskKind+  = Input -- ^ Used for tasks whose results can change independently of their fetched dependencies, i.e. inputs.+  | NonInput -- ^ Used for task whose results only depend on fetched dependencies.++-- | A query that returns a @w@ alongside the ordinary @a@.+data Writer w f a where+  Writer :: f a -> Writer w f (a, w)++instance GEq f => GEq (Writer w f) where+  geq (Writer f) (Writer g) = case geq f g of+    Nothing -> Nothing+    Just Refl -> Just Refl++instance GCompare f => GCompare (Writer w f) where+  gcompare (Writer f) (Writer g) = case gcompare f g of+    GLT -> GLT+    GEQ -> GEQ+    GGT -> GGT++-- | @'writer' write rules@ runs @write w@ each time a @w@ is returned from a+-- rule in @rules@.+writer+  :: forall f w g+  . (forall a. f a -> w -> Task g ())+  -> GenRules (Writer w f) g+  -> GenRules f g+writer write rules key = do+  (res, w) <- rules $ Writer key+  write key w+  return res++-- | @'traceFetch' before after rules@ runs @before q@ before a query is+-- performed from @rules@, and @after q result@ every time a query returns with+-- result @result@. +traceFetch+  :: (forall a. f a -> Task g ())+  -> (forall a. f a -> a -> Task g ())+  -> GenRules f g+  -> GenRules f g+traceFetch before after rules key = do+  before key+  result <- rules key+  after key result+  return result

+ src/Rock/HashTag.hs view

@@ -0,0 +1,19 @@+module Rock.HashTag where++import Protolude++-- | Hash the result of a @k@ query.+--+-- A typical implementation looks like:+--+-- @+-- data Query a where+--   ReadFile :: 'FilePath' -> Query 'Text'+--+-- instance 'HashTag' Query where+--   'hashTagged' query =+--     case query of+--       ReadFile {} -> 'hash'+-- @+class HashTag k where+  hashTagged :: k a -> a -> Int

+ src/Rock/Hashed.hs view

@@ -0,0 +1,30 @@+module Rock.Hashed(Hashed, hashed, unhashed) where++import Protolude++import Data.Functor.Classes+import Text.Show++import Rock.HashTag++data Hashed a = Hashed !a !Int+  deriving (Show)++instance Eq a => Eq (Hashed a) where+  Hashed v1 h1 == Hashed v2 h2 = h1 == h2 && v1 == v2++instance Ord a => Ord (Hashed a) where+  compare (Hashed v1 _) (Hashed v2 _) = compare v1 v2++instance Show1 Hashed where+  liftShowsPrec showa _ d (Hashed a _) = showParen (d > 10)+    $ showString "Hashed " . showa 11 a++instance Hashable (Hashed a) where+  hashWithSalt s (Hashed _ h) = hashWithSalt s h++unhashed :: Hashed a -> a+unhashed (Hashed x _) = x++hashed :: HashTag f => f a -> a -> Hashed a+hashed k v = Hashed v $ hashTagged k v

+ src/Rock/Traces.hs view

@@ -0,0 +1,64 @@+{-# language RankNTypes #-}+{-# language StandaloneDeriving #-}+{-# language TemplateHaskell #-}+{-# language UndecidableInstances #-}+module Rock.Traces where++import Protolude++import Data.Dependent.Map(DMap, GCompare, DSum((:=>)))+import qualified Data.Dependent.Map as DMap+import Data.Dependent.Sum+import Data.Functor.Classes+import Text.Show.Deriving++import Rock.HashTag+import Rock.Hashed++data ValueDeps f a = ValueDeps+  { value :: !(Hashed a)+  , dependencies :: !(DMap f Hashed)+  }++return []++deriving instance (Show a, ShowTag f Hashed) => Show (ValueDeps f a)++instance ShowTag f Hashed => Show1 (ValueDeps f) where+  liftShowsPrec = $(makeLiftShowsPrec ''ValueDeps)++type Traces f = DMap f (ValueDeps f)++verifyDependencies+  :: Monad m+  => (forall a'. f a' -> m (Hashed a'))+  -> ValueDeps f a+  -> m (Maybe a)+verifyDependencies fetchHash (ValueDeps hashedValue deps) = do+  upToDate <- allM (DMap.toList deps) $ \(depKey :=> depValue) -> do+    depValue' <- fetchHash depKey+    return $ hash depValue == hash depValue'+  return $ if upToDate+    then Just $ unhashed hashedValue+    else Nothing+  where+    allM :: Monad m => [a] -> (a -> m Bool) -> m Bool+    allM [] _ = return True+    allM (x:xs) p = do+      b <- p x+      if b then+        allM xs p+      else+        return False++record+  :: (GCompare f, HashTag f)+  => f a+  -> a+  -> DMap f Identity+  -> Traces f+  -> Traces f+record k v deps+  = DMap.insert k+  $ ValueDeps (hashed k v)+  $ DMap.mapWithKey (\k' (Identity v') -> hashed k' v') deps