├── .gitignore ├── Setup.hs ├── stack.yaml ├── src ├── Rock.hs └── Rock │ ├── Traces.hs │ └── Core.hs ├── CHANGELOG.md ├── examples └── Spreadsheet.hs ├── LICENSE ├── .github └── workflows │ └── ci.yml ├── README.md ├── rock.cabal ├── tests └── Main.hs └── .travis.yml /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.16 2 | packages: 3 | - . 4 | extra-deps: 5 | - dependent-hashmap-0.1.0.1 6 | -------------------------------------------------------------------------------- /src/Rock.hs: -------------------------------------------------------------------------------- 1 | module Rock 2 | ( module Rock.Core 3 | , Traces 4 | ) where 5 | 6 | import Rock.Core hiding (Fetch) 7 | import Rock.Traces 8 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Unreleased 2 | 3 | # 0.3.1.2 4 | 5 | - Add docs about query params, mention Eclair in README 6 | - Add note about IO actions 7 | - Fix template stages to build with GHC 9.2.2 8 | - Fix build errors with GHC 9.6.2 9 | - Add CI in GitHub Actions Workflow 10 | 11 | # 0.3.1.1 12 | 13 | - Fix a concurrency bug in `memoiseWithCycleDetection`, where a race condition meant that it could sometimes throw a `Cyclic` exception when there weren't actually cycles 14 | 15 | # 0.3.1.0 16 | 17 | - Add `MonadFix` instance to `Task` 18 | 19 | # 0.3.0.0 20 | 21 | - Add `memoiseWithCycleDetection` and `Cycle`, enabling cycle detection 22 | - Implement `Task` using `ReaderT`, improving performance 23 | - Make buildable with GHC 8.2.2 through 8.8.3 24 | - Switch from the `dependent-map` package to the `dependent-hashmap` for caches 25 | - Remove support for Haxl-style automatic parallelisation 26 | * Remove strategy parameter from `runTask` 27 | * Add `MonadBaseControl`, which allows manual parallelisation using e.g. lifted-async 28 | * Remove `Sequential` type 29 | - Use `IORef`s instead of `MVar`s 30 | - Add `trackM` function 31 | - Remove `invalidateReverseDependencies` in favour of `reachableReverseDependencies` 32 | - Generalise `verifyTraces` to verify using user-supplied data 33 | 34 | # 0.2.0.0 35 | 36 | - Stop using hashes when verifying traces (gets rid of the `Rock.HashTag` and `Rock.Hashed` modules) 37 | - Add reverse dependency tracking 38 | 39 | # 0.1.0.1 40 | 41 | - Fix base-4.12 compatibility 42 | 43 | # 0.1.0.0 44 | 45 | - Initial release 46 | -------------------------------------------------------------------------------- /examples/Spreadsheet.hs: -------------------------------------------------------------------------------- 1 | {-# language FlexibleInstances #-} 2 | {-# language GADTs #-} 3 | {-# language StandaloneDeriving #-} 4 | {-# language TemplateHaskell #-} 5 | 6 | import Control.Monad.IO.Class 7 | import Data.GADT.Compare.TH (deriveGEq) 8 | import Data.Hashable 9 | import Data.Some 10 | import Data.IORef 11 | import qualified Rock 12 | 13 | data Query a where 14 | A :: Query Integer 15 | B :: Query Integer 16 | C :: Query Integer 17 | D :: Query Integer 18 | 19 | deriving instance Show (Query a) 20 | deriveGEq ''Query 21 | 22 | instance Hashable (Query a) where 23 | hashWithSalt salt query = 24 | case query of 25 | A -> hashWithSalt salt (0 :: Int) 26 | B -> hashWithSalt salt (1 :: Int) 27 | C -> hashWithSalt salt (2 :: Int) 28 | D -> hashWithSalt salt (3 :: Int) 29 | 30 | instance Hashable (Some Query) where 31 | hashWithSalt salt (Some query) = hashWithSalt salt query 32 | 33 | rules :: Rock.Rules Query 34 | rules key = do 35 | liftIO $ putStrLn $ "Fetching " <> show key 36 | case key of 37 | A -> pure 10 38 | B -> do 39 | a <- Rock.fetch A 40 | pure $ a + 20 41 | C -> do 42 | a <- Rock.fetch A 43 | pure $ a + 30 44 | D -> 45 | (+) <$> Rock.fetch B <*> Rock.fetch C 46 | 47 | main :: IO () 48 | main = do 49 | do 50 | liftIO $ putStrLn "Running" 51 | result <- Rock.runTask rules (Rock.fetch D) 52 | print result 53 | do 54 | liftIO $ putStrLn "Running with memoisation" 55 | memoVar <- newIORef mempty 56 | result <- Rock.runTask (Rock.memoise memoVar rules) (Rock.fetch D) 57 | liftIO $ print result 58 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Olle Fredriksson (c) 2018-2023 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Olle Fredriksson nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/Rock/Traces.hs: -------------------------------------------------------------------------------- 1 | {-# language FlexibleContexts #-} 2 | {-# language RankNTypes #-} 3 | {-# language StandaloneDeriving #-} 4 | {-# language TemplateHaskell #-} 5 | {-# language UndecidableInstances #-} 6 | module Rock.Traces where 7 | 8 | import Control.Monad.IO.Class 9 | import Data.Constraint.Extras 10 | import Data.Dependent.HashMap(DHashMap) 11 | import qualified Data.Dependent.HashMap as DHashMap 12 | import Data.Dependent.Sum 13 | import Data.Functor.Classes 14 | import Data.GADT.Compare 15 | import Data.GADT.Show 16 | import Data.Hashable 17 | import Data.Some 18 | import Text.Show.Deriving 19 | 20 | data ValueDeps f dep a = ValueDeps 21 | { value :: !a 22 | , dependencies :: !(DHashMap f dep) 23 | } 24 | 25 | return [] 26 | 27 | deriving instance (Show a, GShow f, Has' Show f dep) => Show (ValueDeps f dep a) 28 | 29 | instance (GShow f, Has' Show f dep) => Show1 (ValueDeps f dep) where 30 | liftShowsPrec = $(makeLiftShowsPrec ''ValueDeps) 31 | 32 | type Traces f dep = DHashMap f (ValueDeps f dep) 33 | 34 | verifyDependencies 35 | :: (MonadIO m, GEq f, Has' Eq f dep) 36 | => (forall a'. f a' -> m a') 37 | -> (forall a'. f a' -> a' -> m (dep a')) 38 | -> ValueDeps f dep a 39 | -> m (Maybe a) 40 | verifyDependencies fetch createDependencyRecord (ValueDeps value_ deps) = do 41 | upToDate <- allM (DHashMap.toList deps) $ \(depKey :=> dep) -> do 42 | depValue <- fetch depKey 43 | newDep <- createDependencyRecord depKey depValue 44 | return $ eqTagged depKey depKey dep newDep 45 | return $ if upToDate 46 | then Just value_ 47 | else Nothing 48 | where 49 | allM :: Monad m => [a] -> (a -> m Bool) -> m Bool 50 | allM [] _ = return True 51 | allM (x:xs) p = do 52 | b <- p x 53 | if b then 54 | allM xs p 55 | else 56 | return False 57 | 58 | record 59 | :: (GEq f, Hashable (Some f)) 60 | => f a 61 | -> a 62 | -> DHashMap f g 63 | -> Traces f g 64 | -> Traces f g 65 | record k v deps 66 | = DHashMap.insert k 67 | $ ValueDeps v deps 68 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: Rock CI 2 | 3 | on: [push, pull_request] 4 | 5 | permissions: 6 | contents: read 7 | 8 | jobs: 9 | build: 10 | name: GHC ${{ matrix.ghc-version }} on ${{ matrix.os }} 11 | runs-on: ${{ matrix.os }} 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | os: [ubuntu-latest, macos-latest] 16 | ghc-version: ["9.4.4", "9.6.2"] 17 | 18 | steps: 19 | - uses: actions/checkout@v3 20 | 21 | - name: Set up GHC ${{ matrix.ghc-version }} 22 | uses: haskell-actions/setup@v2 23 | id: setup 24 | with: 25 | ghc-version: ${{ matrix.ghc-version }} 26 | # Defaults, added for clarity: 27 | cabal-version: "latest" 28 | cabal-update: true 29 | 30 | - name: Installed minor versions of GHC and Cabal 31 | shell: bash 32 | run: | 33 | GHC_VERSION=$(ghc --numeric-version) 34 | CABAL_VERSION=$(cabal --numeric-version) 35 | echo "GHC_VERSION=${GHC_VERSION}" >> "${GITHUB_ENV}" 36 | echo "CABAL_VERSION=${CABAL_VERSION}" >> "${GITHUB_ENV}" 37 | 38 | - name: Configure the build 39 | run: | 40 | cabal configure --enable-tests 41 | cabal build --dry-run 42 | # The last step generates dist-newstyle/cache/plan.json for the cache key. 43 | 44 | - name: Restore cached dependencies 45 | uses: actions/cache/restore@v3 46 | id: cache 47 | with: 48 | path: ${{ steps.setup.outputs.cabal-store }} 49 | key: ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-cabal-${{ env.CABAL_VERSION }}-plan-${{ hashFiles('**/plan.json') }} 50 | restore-keys: | 51 | ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-cabal-${{ env.CABAL_VERSION }}- 52 | 53 | - name: Install dependencies 54 | run: | 55 | cabal build all --only-dependencies 56 | 57 | # Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail. 58 | - name: Save cached dependencies 59 | uses: actions/cache/save@v3 60 | # Caches are immutable, trying to save with the same key would error. 61 | if: ${{ steps.cache.outputs.cache-primary-key != steps.cache.outputs.cache-matched-key }} 62 | with: 63 | path: ${{ steps.setup.outputs.cabal-store }} 64 | key: ${{ steps.cache.outputs.cache-primary-key }} 65 | 66 | - name: Build 67 | run: | 68 | cabal build all 69 | 70 | - name: Run tests 71 | run: | 72 | cabal test all 73 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # rock 2 | [![Build Status](https://travis-ci.com/ollef/rock.svg?branch=master)](https://travis-ci.com/ollef/rock) 3 | [![CI Status](https://github.com/ollef/rock/actions/workflows/ci.yml/badge.svg?branch=master)](https://github.com/ollef/rock/actions/workflows/ci.yml) 4 | [![Hackage](https://img.shields.io/hackage/v/rock.svg)](https://hackage.haskell.org/package/rock) 5 | 6 | 7 | 8 | A build system inspired by [Build systems à la carte](https://www.microsoft.com/en-us/research/publication/build-systems-la-carte/). 9 | 10 | Used in [Sixten](https://github.com/ollef/sixten), 11 | [Sixty](https://github.com/ollef/sixty) and 12 | [Eclair](https://github.com/luc-tielen/eclair-lang) to achieve incremental and 13 | query driven compiler architectures. 14 | 15 | ## Example 16 | 17 | ```haskell 18 | {-# language FlexibleInstances #-} 19 | {-# language GADTs #-} 20 | {-# language StandaloneDeriving #-} 21 | {-# language TemplateHaskell #-} 22 | 23 | import Control.Monad.IO.Class 24 | import Data.GADT.Compare.TH (deriveGEq) 25 | import Data.Hashable 26 | import Data.Some 27 | import Data.IORef 28 | import qualified Rock 29 | 30 | data Query a where 31 | A :: Query Integer 32 | B :: Query Integer 33 | C :: Query Integer 34 | D :: Query Integer 35 | 36 | deriving instance Show (Query a) 37 | deriveGEq ''Query 38 | 39 | instance Hashable (Query a) where 40 | hashWithSalt salt query = 41 | case query of 42 | A -> hashWithSalt salt (0 :: Int) 43 | B -> hashWithSalt salt (1 :: Int) 44 | C -> hashWithSalt salt (2 :: Int) 45 | D -> hashWithSalt salt (3 :: Int) 46 | 47 | instance Hashable (Some Query) where 48 | hashWithSalt salt (Some query) = hashWithSalt salt query 49 | 50 | rules :: Rock.Rules Query 51 | rules key = do 52 | liftIO $ putStrLn $ "Fetching " <> show key 53 | case key of 54 | A -> pure 10 55 | B -> do 56 | a <- Rock.fetch A 57 | pure $ a + 20 58 | C -> do 59 | a <- Rock.fetch A 60 | pure $ a + 30 61 | D -> 62 | (+) <$> Rock.fetch B <*> Rock.fetch C 63 | 64 | main :: IO () 65 | main = do 66 | do 67 | liftIO $ putStrLn "Running" 68 | result <- Rock.runTask rules (Rock.fetch D) 69 | print result 70 | do 71 | liftIO $ putStrLn "Running with memoisation" 72 | memoVar <- newIORef mempty 73 | result <- Rock.runTask (Rock.memoise memoVar rules) (Rock.fetch D) 74 | liftIO $ print result 75 | ``` 76 | 77 | Prints 78 | 79 | ``` 80 | Running 81 | Fetching D 82 | Fetching B 83 | Fetching A 84 | Fetching C 85 | Fetching A 86 | 70 87 | Running with memoisation 88 | Fetching D 89 | Fetching B 90 | Fetching A 91 | Fetching C 92 | 70 93 | ``` 94 | 95 | Note: Besides pure computations as shown above, the `Task` data type implements 96 | `MonadIO`, so you can lift IO actions into the `Task` monad by using 97 | `liftIO`! 98 | 99 | ## Query parameters 100 | 101 | If you need to parametrize your queries (e.g. typechecking one specific file), 102 | you can do this by adding additional arguments to your `Query` datatype: 103 | 104 | ```haskell 105 | data Query a where 106 | Parse :: FilePath -> Query AST 107 | Typecheck :: FilePath -> Query (Either TypeError TypedAST) 108 | 109 | rules :: Rock.Rules Query 110 | rules key = case key of 111 | Parse file -> do 112 | _ -- parse the file.. 113 | Typecheck file -> do 114 | ast <- Rock.fetch (Parse file) 115 | _ -- typecheck file.. 116 | ``` 117 | 118 | ## Related projects 119 | 120 | * [Shake](http://hackage.haskell.org/package/shake) 121 | * [Salsa](https://crates.io/crates/salsa) 122 | 123 | ## Contributions 124 | 125 | ... are very welcome, especially in the areas of documentation and examples. 126 | -------------------------------------------------------------------------------- /rock.cabal: -------------------------------------------------------------------------------- 1 | name: rock 2 | version: 0.3.1.2 3 | synopsis: A build system for incremental, parallel, and demand-driven computations 4 | description: See for more 5 | information and 6 | for 7 | examples. 8 | homepage: https://github.com/ollef/rock#readme 9 | license: BSD3 10 | license-file: LICENSE 11 | author: Olle Fredriksson 12 | maintainer: fredriksson.olle@gmail.com 13 | copyright: 2018-2023 Olle Fredriksson 14 | category: Development 15 | build-type: Simple 16 | extra-source-files: 17 | README.md 18 | CHANGELOG.md 19 | cabal-version: >=1.10 20 | tested-with: GHC == 8.2.2 21 | , GHC == 8.4.3 22 | , GHC == 8.6.5 23 | , GHC == 8.8.3 24 | , GHC == 9.2.2 25 | , GHC == 9.4.4 26 | , GHC == 9.6.2 27 | 28 | library 29 | ghc-options: -Wall 30 | -Wcompat 31 | -Widentities 32 | -Wincomplete-record-updates 33 | -Wincomplete-uni-patterns 34 | -Wmissing-home-modules 35 | -Wpartial-fields 36 | -Wredundant-constraints 37 | -Wtabs 38 | -funbox-strict-fields 39 | hs-source-dirs: src 40 | exposed-modules: 41 | Rock 42 | Rock.Core 43 | Rock.Traces 44 | build-depends: base >= 4.7 && < 5 45 | , constraints-extras >= 0.4.0 && < 0.5 46 | , dependent-hashmap >= 0.1.0 && < 0.2 47 | , dependent-sum >= 0.7.2 && < 0.8 48 | , deriving-compat >= 0.6.5 && < 0.7 49 | , hashable >= 1.4.3 50 | , lifted-base >= 0.2.3 && < 0.3 51 | , monad-control >= 1.0.3 && < 1.1 52 | , mtl >= 2.3.1 && < 2.4 53 | , transformers >= 0.6.1 && < 0.7 54 | , transformers-base >= 0.4.6 && < 0.5 55 | , unordered-containers >= 0.2.19 && < 0.3 56 | default-language: Haskell2010 57 | default-extensions: OverloadedStrings 58 | 59 | source-repository head 60 | type: git 61 | location: https://github.com/ollef/rock 62 | 63 | flag examples 64 | Description: "Build examples" 65 | Default: False 66 | Manual: True 67 | 68 | executable rock-spreadsheet 69 | if !flag(examples) 70 | buildable: False 71 | main-is: Spreadsheet.hs 72 | ghc-options: -Wall 73 | -threaded 74 | hs-source-dirs: examples 75 | default-language: Haskell2010 76 | build-depends: base 77 | , dependent-sum 78 | , dependent-sum-template 79 | , hashable 80 | , rock 81 | 82 | test-suite test-rock 83 | type: exitcode-stdio-1.0 84 | main-is: Main.hs 85 | hs-source-dirs: tests 86 | ghc-options: -Wall 87 | -Wcompat 88 | -Widentities 89 | -Wincomplete-record-updates 90 | -Wincomplete-uni-patterns 91 | -Wmissing-home-modules 92 | -Wpartial-fields 93 | -Wredundant-constraints 94 | -Wtabs 95 | -funbox-strict-fields 96 | build-depends: base >=4.7 && <5 97 | , constraints 98 | , constraints-extras 99 | , dependent-hashmap 100 | , dependent-sum 101 | , hashable 102 | , hedgehog 103 | , mtl 104 | , rock 105 | , unordered-containers 106 | default-language: Haskell2010 107 | -------------------------------------------------------------------------------- /tests/Main.hs: -------------------------------------------------------------------------------- 1 | {-# language CPP #-} 2 | {-# language FlexibleInstances #-} 3 | {-# language GADTs #-} 4 | {-# language MultiParamTypeClasses #-} 5 | {-# language RankNTypes #-} 6 | {-# language StandaloneDeriving #-} 7 | {-# language TypeApplications #-} 8 | {-# language TemplateHaskell #-} 9 | {-# language TypeFamilies #-} 10 | module Main where 11 | 12 | import Control.Monad 13 | import Control.Monad.Identity 14 | import Control.Monad.IO.Class 15 | import Data.Constraint.Extras 16 | import Data.Constraint.Extras.TH 17 | import qualified Data.Dependent.HashMap as DHashMap 18 | import Data.Functor.Const 19 | import Data.GADT.Compare 20 | import Data.GADT.Show 21 | import Data.Hashable 22 | import Data.IORef 23 | import Data.List (sort) 24 | #if !MIN_VERSION_base(4,11,0) 25 | import Data.Semigroup 26 | #endif 27 | import Data.Some 28 | import Data.Type.Equality ((:~:)(Refl)) 29 | import Hedgehog 30 | import qualified Hedgehog.Gen as Gen 31 | import qualified Hedgehog.Range as Range 32 | import Rock 33 | 34 | data Key v where 35 | IntKey :: Int -> Key Int 36 | StringKey :: String -> Key String 37 | 38 | deriving instance Show (Key v) 39 | 40 | instance GShow Key where 41 | gshowsPrec = showsPrec 42 | 43 | instance GShow (Writer w Key) where 44 | gshowsPrec d (Writer key) = showsPrec d key 45 | 46 | instance Hashable (Some Key) where 47 | hashWithSalt salt (Some key) = 48 | case key of 49 | IntKey i -> hashWithSalt salt (0 :: Int, i) 50 | StringKey s -> hashWithSalt salt (1 :: Int, s) 51 | 52 | instance GEq Key where 53 | geq (IntKey i1) (IntKey i2) 54 | | i1 == i2 = 55 | Just Refl 56 | geq (StringKey s1) (StringKey s2) 57 | | s1 == s2 = 58 | Just Refl 59 | geq _ _ = 60 | Nothing 61 | 62 | instance GCompare Key where 63 | gcompare (IntKey i1) (IntKey i2) 64 | | i1 == i2 = 65 | GEQ 66 | | i1 < i2 = 67 | GLT 68 | | otherwise = 69 | GGT 70 | gcompare (IntKey _) _ = 71 | GLT 72 | gcompare _ (IntKey _) = 73 | GGT 74 | gcompare (StringKey s1) (StringKey s2) 75 | | s1 == s2 = 76 | GEQ 77 | | s1 < s2 = 78 | GLT 79 | | otherwise = 80 | GGT 81 | 82 | deriveArgDict ''Key 83 | 84 | int :: Gen Int 85 | int = Gen.int (Range.linear 0 100) 86 | 87 | string :: Gen String 88 | string = Gen.string (Range.linear 0 100) Gen.ascii 89 | 90 | key :: Gen (Some Key) 91 | key = 92 | Gen.choice 93 | [ Some . IntKey <$> int 94 | , Some . StringKey <$> string 95 | ] 96 | 97 | addRules :: Rules Key 98 | addRules key_ = 99 | case key_ of 100 | IntKey i -> 101 | pure $ i + 1 102 | 103 | StringKey s -> 104 | pure $ s <> "a" 105 | 106 | withKeyFetchedCallback :: (Some f -> IO ()) -> GenRules f g -> GenRules f g 107 | withKeyFetchedCallback keyFetched rules key_ = do 108 | liftIO $ keyFetched $ Some key_ 109 | rules key_ 110 | 111 | prop_track_tracks :: Property 112 | prop_track_tracks = 113 | property $ do 114 | Some key_ <- forAll key 115 | startedVar <- liftIO $ newIORef mempty 116 | let 117 | rules :: Rules Key 118 | rules = 119 | memoise startedVar addRules 120 | 121 | ((), deps) <- liftIO $ runTask rules $ do 122 | void $ fetch key_ 123 | track (\_ _ -> Const ()) $ void $ fetch key_ 124 | 125 | DHashMap.keys deps === [Some key_] 126 | 127 | prop_memoise_memoises :: Property 128 | prop_memoise_memoises = 129 | property $ do 130 | Some key_ <- forAll key 131 | fetchedKeysVar <- liftIO $ newIORef [] 132 | startedVar <- liftIO $ newIORef mempty 133 | let 134 | keyFetched k = 135 | atomicModifyIORef fetchedKeysVar $ \ks -> (k : ks, ()) 136 | 137 | rules :: Rules Key 138 | rules = 139 | memoise startedVar (withKeyFetchedCallback keyFetched addRules) 140 | 141 | liftIO $ runTask rules $ do 142 | void $ fetch key_ 143 | void $ fetch key_ 144 | 145 | fetchedKeys <- liftIO $ readIORef fetchedKeysVar 146 | fetchedKeys === [Some key_] 147 | 148 | inputRules :: Int -> GenRules (Writer TaskKind Key) Key 149 | inputRules input (Writer key_) = 150 | case key_ of 151 | IntKey 0 -> do 152 | pure (input, Input) 153 | 154 | IntKey i -> do 155 | pure (i + 1, NonInput) 156 | 157 | StringKey "dependent" -> do 158 | i <- fetch $ IntKey 0 159 | j <- fetch $ IntKey 1 160 | pure (show i <> show j, NonInput) 161 | 162 | StringKey s -> do 163 | i <- fetch $ IntKey 1 164 | j <- fetch $ IntKey 2 165 | pure (s <> show i <> show j, NonInput) 166 | 167 | prop_verifyTraces :: Property 168 | prop_verifyTraces = 169 | property $ do 170 | fetchedKeysVar <- liftIO $ newIORef [] 171 | startedVar <- liftIO $ newIORef mempty 172 | tracesVar <- liftIO $ newIORef mempty 173 | let 174 | keyFetched k = 175 | atomicModifyIORef fetchedKeysVar $ \ks -> (k : ks, ()) 176 | 177 | rules :: Int -> Rules Key 178 | rules input = 179 | memoise startedVar $ 180 | verifyTraces 181 | tracesVar 182 | (\query value -> 183 | pure $ Const $ has' @Hashable @Identity query $ hash $ Identity value 184 | ) $ 185 | withKeyFetchedCallback keyFetched $ 186 | inputRules input 187 | 188 | nonDependentKey <- forAll $ Gen.filter (/= "dependent") string 189 | 190 | liftIO $ runTask (rules 1) $ do 191 | void $ fetch $ StringKey "dependent" 192 | void $ fetch $ StringKey nonDependentKey 193 | 194 | liftIO $ atomicWriteIORef startedVar mempty 195 | liftIO $ atomicWriteIORef fetchedKeysVar mempty 196 | 197 | liftIO $ runTask (rules 2) $ do 198 | void $ fetch $ StringKey "dependent" 199 | void $ fetch $ StringKey nonDependentKey 200 | 201 | fetchedKeys <- liftIO $ readIORef fetchedKeysVar 202 | sort fetchedKeys === [Some $ Writer $ IntKey 0, Some $ Writer $ StringKey "dependent"] 203 | 204 | main :: IO () 205 | main = 206 | void $ checkParallel $$(discover) 207 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # haskell-ci 'rock.cabal' 4 | # 5 | # For more information, see https://github.com/haskell-CI/haskell-ci 6 | # 7 | # version: 0.9.20200225 8 | # 9 | version: ~> 1.0 10 | language: c 11 | os: linux 12 | dist: xenial 13 | git: 14 | # whether to recursively clone submodules 15 | submodules: false 16 | cache: 17 | directories: 18 | - $HOME/.cabal/packages 19 | - $HOME/.cabal/store 20 | - $HOME/.hlint 21 | before_cache: 22 | - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log 23 | # remove files that are regenerated by 'cabal update' 24 | - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* 25 | - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json 26 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache 27 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar 28 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx 29 | - rm -rfv $CABALHOME/packages/head.hackage 30 | jobs: 31 | include: 32 | - compiler: ghc-8.8.3 33 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.0"]}} 34 | os: linux 35 | - compiler: ghc-8.6.5 36 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.0"]}} 37 | os: linux 38 | - compiler: ghc-8.4.3 39 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.3","cabal-install-3.0"]}} 40 | os: linux 41 | - compiler: ghc-8.2.2 42 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.0"]}} 43 | os: linux 44 | before_install: 45 | - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') 46 | - WITHCOMPILER="-w $HC" 47 | - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') 48 | - HCPKG="$HC-pkg" 49 | - unset CC 50 | - CABAL=/opt/ghc/bin/cabal 51 | - CABALHOME=$HOME/.cabal 52 | - export PATH="$CABALHOME/bin:$PATH" 53 | - TOP=$(pwd) 54 | - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" 55 | - echo $HCNUMVER 56 | - CABAL="$CABAL -vnormal+nowrap" 57 | - set -o pipefail 58 | - TEST=--enable-tests 59 | - BENCH=--enable-benchmarks 60 | - HEADHACKAGE=false 61 | - rm -f $CABALHOME/config 62 | - | 63 | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config 64 | echo "remote-build-reporting: anonymous" >> $CABALHOME/config 65 | echo "write-ghc-environment-files: always" >> $CABALHOME/config 66 | echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config 67 | echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config 68 | echo "world-file: $CABALHOME/world" >> $CABALHOME/config 69 | echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config 70 | echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config 71 | echo "installdir: $CABALHOME/bin" >> $CABALHOME/config 72 | echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config 73 | echo "store-dir: $CABALHOME/store" >> $CABALHOME/config 74 | echo "install-dirs user" >> $CABALHOME/config 75 | echo " prefix: $CABALHOME" >> $CABALHOME/config 76 | echo "repository hackage.haskell.org" >> $CABALHOME/config 77 | echo " url: http://hackage.haskell.org/" >> $CABALHOME/config 78 | install: 79 | - ${CABAL} --version 80 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 81 | - | 82 | echo "program-default-options" >> $CABALHOME/config 83 | echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config 84 | - cat $CABALHOME/config 85 | - rm -fv cabal.project cabal.project.local cabal.project.freeze 86 | - travis_retry ${CABAL} v2-update -v 87 | # Generate cabal.project 88 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 89 | - touch cabal.project 90 | - | 91 | echo "packages: ." >> cabal.project 92 | - | 93 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(rock)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 94 | - cat cabal.project || true 95 | - cat cabal.project.local || true 96 | - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi 97 | - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} 98 | - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" 99 | - rm cabal.project.freeze 100 | - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all 101 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all 102 | script: 103 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 104 | # Packaging... 105 | - ${CABAL} v2-sdist all 106 | # Unpacking... 107 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 108 | - cd ${DISTDIR} || false 109 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; 110 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; 111 | - PKGDIR_rock="$(find . -maxdepth 1 -type d -regex '.*/rock-[0-9.]*')" 112 | # Generate cabal.project 113 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 114 | - touch cabal.project 115 | - | 116 | echo "packages: ${PKGDIR_rock}" >> cabal.project 117 | - | 118 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(rock)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 119 | - cat cabal.project || true 120 | - cat cabal.project.local || true 121 | # Building... 122 | # this builds all libraries and executables (without tests/benchmarks) 123 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all 124 | # Building with tests and benchmarks... 125 | # build & run tests, build benchmarks 126 | - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all 127 | # Testing... 128 | - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all 129 | # cabal check... 130 | - (cd ${PKGDIR_rock} && ${CABAL} -vnormal check) 131 | # haddock... 132 | - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all 133 | # Building without installed constraints for packages in global-db... 134 | - rm -f cabal.project.local 135 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all 136 | 137 | # REGENDATA ("0.9.20200225",["rock.cabal"]) 138 | # EOF 139 | -------------------------------------------------------------------------------- /src/Rock/Core.hs: -------------------------------------------------------------------------------- 1 | {-# language CPP #-} 2 | {-# language DefaultSignatures #-} 3 | {-# language FlexibleContexts #-} 4 | {-# language FlexibleInstances #-} 5 | {-# language FunctionalDependencies #-} 6 | {-# language GADTs #-} 7 | {-# language GeneralizedNewtypeDeriving #-} 8 | {-# language RankNTypes #-} 9 | {-# language ScopedTypeVariables #-} 10 | {-# language TupleSections #-} 11 | {-# language TypeFamilies #-} 12 | {-# language TypeOperators #-} 13 | {-# language UndecidableInstances #-} 14 | module Rock.Core where 15 | 16 | import Control.Concurrent.Lifted 17 | import Control.Exception.Lifted 18 | import Data.IORef.Lifted 19 | import Control.Monad 20 | import Control.Monad.Base 21 | import Control.Monad.Cont 22 | import Control.Monad.Except 23 | import Control.Monad.Fix 24 | import Control.Monad.Identity 25 | import Control.Monad.Reader 26 | import qualified Control.Monad.RWS.Lazy as Lazy 27 | import qualified Control.Monad.RWS.Strict as Strict 28 | import qualified Control.Monad.State.Lazy as Lazy 29 | import qualified Control.Monad.State.Strict as Strict 30 | import Control.Monad.Trans.Control 31 | import Control.Monad.Trans.Maybe 32 | import qualified Control.Monad.Writer.Lazy as Lazy 33 | import qualified Control.Monad.Writer.Strict as Strict 34 | import Data.Bifunctor 35 | import Data.Constraint.Extras 36 | import Data.Dependent.HashMap (DHashMap) 37 | import qualified Data.Dependent.HashMap as DHashMap 38 | import Data.Dependent.Sum 39 | import Data.Foldable 40 | import Data.Functor.Const 41 | import Data.GADT.Compare (GEq, GCompare, geq, gcompare, GOrdering(..)) 42 | import Data.GADT.Show (GShow) 43 | import Data.Hashable 44 | import Data.HashMap.Lazy (HashMap) 45 | import qualified Data.HashMap.Lazy as HashMap 46 | import Data.HashSet (HashSet) 47 | import qualified Data.HashSet as HashSet 48 | import Data.Maybe 49 | import Data.Typeable 50 | #if !MIN_VERSION_base(4,11,0) 51 | import Data.Semigroup 52 | #endif 53 | import Data.Some 54 | 55 | import Rock.Traces(Traces) 56 | import qualified Rock.Traces as Traces 57 | 58 | ------------------------------------------------------------------------------- 59 | -- * Types 60 | 61 | -- | A function which, given an @f@ query, returns a 'Task' allowed to make @f@ 62 | -- queries to compute its result. 63 | type Rules f = GenRules f f 64 | 65 | -- | A function which, given an @f@ query, returns a 'Task' allowed to make @g@ 66 | -- queries to compute its result. 67 | type GenRules f g = forall a. f a -> Task g a 68 | 69 | -- | An @IO@ action that is allowed to make @f@ queries using the 'fetch' 70 | -- method from its 'MonadFetch' instance. 71 | newtype Task f a = Task { unTask :: ReaderT (Fetch f) IO a } 72 | deriving 73 | (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadFix) 74 | 75 | newtype Fetch f = Fetch (forall a. f a -> IO a) 76 | 77 | ------------------------------------------------------------------------------- 78 | -- * Fetch class 79 | 80 | -- | Monads that can make @f@ queries by 'fetch'ing them. 81 | class Monad m => MonadFetch f m | m -> f where 82 | fetch :: f a -> m a 83 | default fetch 84 | :: (MonadTrans t, MonadFetch f m1, m ~ t m1) 85 | => f a 86 | -> m a 87 | fetch = lift . fetch 88 | 89 | instance MonadFetch f m => MonadFetch f (ContT r m) 90 | instance MonadFetch f m => MonadFetch f (ExceptT e m) 91 | instance MonadFetch f m => MonadFetch f (IdentityT m) 92 | instance MonadFetch f m => MonadFetch f (MaybeT m) 93 | instance MonadFetch f m => MonadFetch f (ReaderT r m) 94 | instance (MonadFetch f m, Monoid w) => MonadFetch f (Strict.RWST r w s m) 95 | instance (MonadFetch f m, Monoid w) => MonadFetch f (Lazy.RWST r w s m) 96 | instance MonadFetch f m => MonadFetch f (Strict.StateT s m) 97 | instance MonadFetch f m => MonadFetch f (Lazy.StateT s m) 98 | instance (Monoid w, MonadFetch f m) => MonadFetch f (Strict.WriterT w m) 99 | instance (Monoid w, MonadFetch f m) => MonadFetch f (Lazy.WriterT w m) 100 | 101 | ------------------------------------------------------------------------------- 102 | -- Instances 103 | 104 | instance MonadFetch f (Task f) where 105 | {-# INLINE fetch #-} 106 | fetch key = Task $ do 107 | io <- asks (\(Fetch fetch_) -> fetch_ key) 108 | liftIO io 109 | 110 | instance MonadBaseControl IO (Task f) where 111 | type StM (Task f) a = StM (ReaderT (Fetch f) IO) a 112 | liftBaseWith k = Task $ liftBaseWith $ \ma -> k $ ma . unTask 113 | restoreM = Task . restoreM 114 | 115 | ------------------------------------------------------------------------------- 116 | -- * Transformations 117 | 118 | -- | Transform the type of queries that a 'Task' performs. 119 | transFetch 120 | :: (forall b. f b -> Task f' b) 121 | -> Task f a 122 | -> Task f' a 123 | transFetch f (Task task) = 124 | Task $ ReaderT $ \fetch_ -> 125 | runReaderT task $ Fetch $ \key -> 126 | runReaderT (unTask $ f key) fetch_ 127 | 128 | ------------------------------------------------------------------------------- 129 | -- * Running tasks 130 | 131 | -- | Perform a 'Task', fetching dependency queries from the given 'Rules' 132 | -- function. 133 | runTask :: Rules f -> Task f a -> IO a 134 | runTask rules (Task task) = 135 | runReaderT task $ Fetch $ runTask rules . rules 136 | 137 | ------------------------------------------------------------------------------- 138 | -- * Task combinators 139 | 140 | -- | Track the query dependencies of a 'Task' in a 'DHashMap'. 141 | track 142 | :: forall f g a. (GEq f, Hashable (Some f)) 143 | => (forall a'. f a' -> a' -> g a') 144 | -> Task f a 145 | -> Task f (a, DHashMap f g) 146 | track f = 147 | trackM $ \key -> pure . f key 148 | 149 | -- | Track the query dependencies of a 'Task' in a 'DHashMap'. Monadic version. 150 | trackM 151 | :: forall f g a. (GEq f, Hashable (Some f)) 152 | => (forall a'. f a' -> a' -> Task f (g a')) 153 | -> Task f a 154 | -> Task f (a, DHashMap f g) 155 | trackM f task = do 156 | depsVar <- newIORef mempty 157 | let 158 | record :: f b -> Task f b 159 | record key = do 160 | value <- fetch key 161 | g <- f key value 162 | atomicModifyIORef depsVar $ (, ()) . DHashMap.insert key g 163 | return value 164 | result <- transFetch record task 165 | deps <- readIORef depsVar 166 | return (result, deps) 167 | 168 | -- | Remember what @f@ queries have already been performed and their results in 169 | -- a 'DHashMap', and reuse them if a query is performed again a second time. 170 | -- 171 | -- The 'DHashMap' should typically not be reused if there has been some change that 172 | -- might make a query return a different result. 173 | memoise 174 | :: forall f g 175 | . (GEq f, Hashable (Some f)) 176 | => IORef (DHashMap f MVar) 177 | -> GenRules f g 178 | -> GenRules f g 179 | memoise startedVar rules (key :: f a) = do 180 | maybeValueVar <- DHashMap.lookup key <$> readIORef startedVar 181 | case maybeValueVar of 182 | Nothing -> do 183 | valueVar <- newEmptyMVar 184 | join $ atomicModifyIORef startedVar $ \started -> 185 | case DHashMap.alterLookup (Just . fromMaybe valueVar) key started of 186 | (Nothing, started') -> 187 | ( started' 188 | , do 189 | value <- rules key 190 | putMVar valueVar value 191 | return value 192 | ) 193 | 194 | (Just valueVar', _started') -> 195 | (started, readMVar valueVar') 196 | 197 | Just valueVar -> 198 | readMVar valueVar 199 | 200 | newtype Cyclic f = Cyclic (Some f) 201 | deriving Show 202 | 203 | instance (GShow f, Typeable f) => Exception (Cyclic f) 204 | 205 | data MemoEntry a 206 | = Started !ThreadId !(MVar (Maybe a)) !(MVar (Maybe [ThreadId])) 207 | | Done !a 208 | 209 | -- | Like 'memoise', but throw @'Cyclic' f@ if a query depends on itself, directly or 210 | -- indirectly. 211 | -- 212 | -- The 'HashMap' represents dependencies between threads and should not be 213 | -- reused between invocations. 214 | memoiseWithCycleDetection 215 | :: forall f g 216 | . (Typeable f, GShow f, GEq f, Hashable (Some f)) 217 | => IORef (DHashMap f MemoEntry) 218 | -> IORef (HashMap ThreadId ThreadId) 219 | -> GenRules f g 220 | -> GenRules f g 221 | memoiseWithCycleDetection startedVar depsVar rules = 222 | rules' 223 | where 224 | rules' (key :: f a) = do 225 | maybeEntry <- DHashMap.lookup key <$> readIORef startedVar 226 | case maybeEntry of 227 | Nothing -> do 228 | threadId <- myThreadId 229 | valueVar <- newEmptyMVar 230 | waitVar <- newMVar $ Just [] 231 | join $ atomicModifyIORef startedVar $ \started -> 232 | case DHashMap.alterLookup (Just . fromMaybe (Started threadId valueVar waitVar)) key started of 233 | (Nothing, started') -> 234 | ( started' 235 | , (do 236 | value <- rules key 237 | join $ modifyMVar waitVar $ \maybeWaitingThreads -> do 238 | case maybeWaitingThreads of 239 | Nothing -> 240 | error "impossible" 241 | 242 | Just waitingThreads -> 243 | return 244 | ( Nothing 245 | , atomicModifyIORef depsVar $ \deps -> 246 | ( foldl' (flip HashMap.delete) deps waitingThreads 247 | , () 248 | ) 249 | ) 250 | atomicModifyIORef startedVar $ \started'' -> 251 | (DHashMap.insert key (Done value) started'', ()) 252 | putMVar valueVar $ Just value 253 | return value 254 | ) `catch` \(e :: Cyclic f) -> do 255 | atomicModifyIORef startedVar $ \started'' -> 256 | (DHashMap.delete key started'', ()) 257 | putMVar valueVar Nothing 258 | throwIO e 259 | ) 260 | 261 | (Just entry, _started') -> 262 | (started, waitFor entry) 263 | 264 | Just entry -> 265 | waitFor entry 266 | where 267 | waitFor entry = 268 | case entry of 269 | Started onThread valueVar waitVar -> do 270 | threadId <- myThreadId 271 | modifyMVar_ waitVar $ \maybeWaitingThreads -> do 272 | case maybeWaitingThreads of 273 | Nothing -> 274 | return maybeWaitingThreads 275 | Just waitingThreads -> do 276 | join $ atomicModifyIORef depsVar $ \deps -> do 277 | let deps' = HashMap.insert threadId onThread deps 278 | if detectCycle threadId deps' then 279 | ( deps 280 | , throwIO $ Cyclic $ Some key 281 | ) 282 | else 283 | ( deps' 284 | , return () 285 | ) 286 | return $ Just $ threadId : waitingThreads 287 | maybeValue <- readMVar valueVar 288 | maybe (rules' key) return maybeValue 289 | 290 | Done value -> 291 | return value 292 | 293 | detectCycle threadId deps = 294 | go threadId 295 | where 296 | go tid = 297 | case HashMap.lookup tid deps of 298 | Nothing -> False 299 | Just dep 300 | | dep == threadId -> True 301 | | otherwise -> go dep 302 | 303 | -- | Remember the results of previous @f@ queries and what their dependencies 304 | -- were then. 305 | -- 306 | -- If all dependencies of a 'NonInput' query are the same, reuse the old result. 307 | -- 'Input' queries are not reused. 308 | verifyTraces 309 | :: forall f dep 310 | . (Hashable (Some f), GEq f, Has' Eq f dep, Typeable f, GShow f) 311 | => IORef (Traces f dep) 312 | -> (forall a. f a -> a -> Task f (dep a)) 313 | -> GenRules (Writer TaskKind f) f 314 | -> Rules f 315 | verifyTraces tracesVar createDependencyRecord rules key = do 316 | traces <- readIORef tracesVar 317 | maybeValue <- case DHashMap.lookup key traces of 318 | Nothing -> return Nothing 319 | Just oldValueDeps -> 320 | Traces.verifyDependencies fetch createDependencyRecord oldValueDeps `catch` \(_ :: Cyclic f) -> 321 | pure Nothing 322 | case maybeValue of 323 | Nothing -> do 324 | ((value, taskKind), deps) <- trackM createDependencyRecord $ rules $ Writer key 325 | case taskKind of 326 | Input -> 327 | return () 328 | NonInput -> 329 | atomicModifyIORef tracesVar 330 | $ (, ()) . Traces.record key value deps 331 | return value 332 | Just value -> return value 333 | 334 | data TaskKind 335 | = Input -- ^ Used for tasks whose results can change independently of their fetched dependencies, i.e. inputs. 336 | | NonInput -- ^ Used for task whose results only depend on fetched dependencies. 337 | 338 | -- | A query that returns a @w@ alongside the ordinary @a@. 339 | data Writer w f a where 340 | Writer :: f a -> Writer w f (a, w) 341 | 342 | instance GEq f => GEq (Writer w f) where 343 | geq (Writer f) (Writer g) = case geq f g of 344 | Nothing -> Nothing 345 | Just Refl -> Just Refl 346 | 347 | instance GCompare f => GCompare (Writer w f) where 348 | gcompare (Writer f) (Writer g) = case gcompare f g of 349 | GLT -> GLT 350 | GEQ -> GEQ 351 | GGT -> GGT 352 | 353 | -- | @'writer' write rules@ runs @write w@ each time a @w@ is returned from a 354 | -- rule in @rules@. 355 | writer 356 | :: forall f w g 357 | . (forall a. f a -> w -> Task g ()) 358 | -> GenRules (Writer w f) g 359 | -> GenRules f g 360 | writer write rules key = do 361 | (res, w) <- rules $ Writer key 362 | write key w 363 | return res 364 | 365 | -- | @'traceFetch' before after rules@ runs @before q@ before a query is 366 | -- performed from @rules@, and @after q result@ every time a query returns with 367 | -- result @result@. 368 | traceFetch 369 | :: (forall a. f a -> Task g ()) 370 | -> (forall a. f a -> a -> Task g ()) 371 | -> GenRules f g 372 | -> GenRules f g 373 | traceFetch before after rules key = do 374 | before key 375 | result <- rules key 376 | after key result 377 | return result 378 | 379 | type ReverseDependencies f = HashMap (Some f) (HashSet (Some f)) 380 | 381 | -- | Write reverse dependencies to the 'IORef. 382 | trackReverseDependencies 383 | :: (GEq f, Hashable (Some f)) 384 | => IORef (ReverseDependencies f) 385 | -> Rules f 386 | -> Rules f 387 | trackReverseDependencies reverseDepsVar rules key = do 388 | (res, deps) <- track (\_ _ -> Const ()) $ rules key 389 | unless (DHashMap.null deps) $ do 390 | let newReverseDeps = HashMap.fromListWith (<>) 391 | [ (Some depKey, HashSet.singleton $ Some key) 392 | | depKey :=> Const () <- DHashMap.toList deps 393 | ] 394 | atomicModifyIORef reverseDepsVar $ (, ()) . HashMap.unionWith (<>) newReverseDeps 395 | pure res 396 | 397 | -- | @'reachableReverseDependencies' key@ returns all keys reachable, by 398 | -- reverse dependency, from @key@ from the input 'DHashMap'. It also returns the 399 | -- reverse dependency map with those same keys removed. 400 | reachableReverseDependencies 401 | :: (GEq f, Hashable (Some f)) 402 | => f a 403 | -> ReverseDependencies f 404 | -> (DHashMap f (Const ()), ReverseDependencies f) 405 | reachableReverseDependencies key reverseDeps = 406 | foldl' 407 | (\(m', reverseDeps') (Some key') -> first (<> m') $ reachableReverseDependencies key' reverseDeps') 408 | (DHashMap.singleton key $ Const (), HashMap.delete (Some key) reverseDeps) 409 | (HashSet.toList $ HashMap.lookupDefault mempty (Some key) reverseDeps) 410 | --------------------------------------------------------------------------------