🎸

Author: ollef

.gitignore

@@ -0,0 +1 @@
+.stack-work

LICENSE

@@ -0,0 +1,30 @@
+Copyright Olle Fredriksson (c) 2018
+
+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 Author name here 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

@@ -0,0 +1 @@
+# rock

Setup.hs

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

rock.cabal

@@ -0,0 +1,43 @@
+name:                rock
+version:             0.1.0.0
+-- synopsis:
+-- description:
+homepage:            https://github.com/ollef/rock#readme
+license:             BSD3
+license-file:        LICENSE
+author:              Olle Fredriksson
+maintainer:          [email protected]
+copyright:           2018 Olle Fredriksson
+category:            Web
+build-type:          Simple
+extra-source-files:  README.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:
+                       Examples
+                       Hashed
+                       Task
+                       VerifyingTraces
+  build-depends:       base >= 4.7 && < 5
+                     , dependent-map
+                     , dependent-sum
+                     , hashable
+                     , protolude
+  default-language:    Haskell2010
+  default-extensions:  OverloadedStrings, NoImplicitPrelude
+
+source-repository head
+  type:     git
+  location: https://github.com/ollef/rock

src/Examples.hs

@@ -0,0 +1,147 @@
+{-# language DeriveGeneric #-}
+{-# language GADTs #-}
+{-# language MultiParamTypeClasses #-}
+{-# language RankNTypes #-}
+{-# language StandaloneDeriving #-}
+module Examples where
+
+import Protolude
+
+import Data.Dependent.Sum
+import Data.GADT.Compare
+import Data.GADT.Show
+import Text.Show
+
+import Hashed
+import Task
+
+-------------------------------------------------------------------------------
+data ModuleName = ModuleName
+  deriving (Eq, Ord, Show, Generic)
+instance Hashable ModuleName
+data ModuleHeader = ModuleHeader ModuleName
+  deriving (Eq, Ord, Show, Generic)
+instance Hashable ModuleHeader
+data ParsedModule = ParsedModule ModuleHeader
+  deriving (Eq, Ord, Show, Generic)
+instance Hashable ParsedModule
+
+data TaskKey a where
+  ParseModuleHeader :: ModuleName -> TaskKey (ModuleHeader, Text)
+  ParseModule :: ModuleName -> TaskKey ParsedModule
+
+instance GEq TaskKey where
+  geq a b = case gcompare a b of
+    GLT -> Nothing
+    GEQ -> Just Refl
+    GGT -> Nothing
+
+gcompareEq :: Ord x => x -> x -> GOrdering a a
+gcompareEq x y = case compare x y of
+  EQ -> GEQ
+  LT -> GLT
+  GT -> GGT
+
+instance GCompare TaskKey where
+  gcompare (ParseModuleHeader x) (ParseModuleHeader y) = gcompareEq x y
+  gcompare (ParseModule x) (ParseModule y) = gcompareEq x y
+  gcompare ParseModuleHeader {} _ = GLT
+  gcompare _ ParseModuleHeader {} = GGT
+
+deriving instance Show (TaskKey a)
+
+instance HashTag TaskKey Identity where
+  hashTagged ParseModuleHeader {} = hash
+  hashTagged ParseModule {} = hash
+
+type CompilerTask = Task TaskKey Identity
+type CompilerTasks = Tasks TaskKey Identity
+
+compilerTasks :: CompilerTasks
+compilerTasks (ParseModuleHeader mname) = Identity <$> parseModuleHeader mname
+compilerTasks (ParseModule mname) = Identity <$> parseModule mname
+
+parseModuleHeader :: ModuleName -> CompilerTask (ModuleHeader, Text)
+parseModuleHeader mname = pure (ModuleHeader mname, "")
+
+parseModule :: ModuleName -> CompilerTask ParsedModule
+parseModule mname = do
+  Identity (header, _t) <- fetch (ParseModuleHeader mname)
+  pure $ ParsedModule header
+
+-------------------------------------------------------------------------------
+data SheetKey a where
+  A :: SheetKey Integer
+  B :: SheetKey Integer
+  C :: SheetKey Integer
+  D :: SheetKey Integer
+
+instance GEq SheetKey where
+  geq a b = case gcompare a b of
+    GLT -> Nothing
+    GEQ -> Just Refl
+    GGT -> Nothing
+
+instance GCompare SheetKey where
+  gcompare A A = GEQ
+  gcompare B B = GEQ
+  gcompare C C = GEQ
+  gcompare D D = GEQ
+  gcompare A _ = GLT
+  gcompare _ A = GGT
+  gcompare B _ = GLT
+  gcompare _ B = GGT
+  gcompare C _ = GLT
+  gcompare _ C = GGT
+
+deriving instance Show (SheetKey a)
+
+instance HashTag SheetKey Identity where
+  hashTagged A = hash
+  hashTagged B = hash
+  hashTagged C = hash
+  hashTagged D = hash
+
+instance GShow SheetKey where
+  gshowsPrec = showsPrec
+
+instance ShowTag SheetKey Identity where
+  showTaggedPrec A = showsPrec
+  showTaggedPrec B = showsPrec
+  showTaggedPrec C = showsPrec
+  showTaggedPrec D = showsPrec
+
+type SheetTask = Task SheetKey Identity
+type SheetTasks = Tasks SheetKey Identity
+
+sheetTasks :: SheetTasks
+sheetTasks key = do
+  liftIO $ putText $ "computing " <> Protolude.show key
+  case key of
+    A -> pure $ Identity 10
+    B -> do
+      Identity a <- fetch A
+      pure $ Identity $ a + 20
+    C -> do
+      Identity a <- fetch A
+      pure $ Identity $ a + 30
+    D -> do
+      Identity b <- fetch B
+      Identity c <- fetch C
+      pure $ Identity $ b + c
+
+sheetTasks2 :: SheetTasks
+sheetTasks2 key = do
+  liftIO $ putText $ "computing 2 " <> Protolude.show key
+  case key of
+    A -> pure $ Identity 12
+    B -> do
+      Identity a <- fetch A
+      pure $ Identity $ a + 10
+    C -> do
+      Identity a <- fetch A
+      pure $ Identity $ a + 20
+    D -> do
+      Identity b <- fetch B
+      Identity c <- fetch C
+      pure $ Identity $ b + c

src/Hashed.hs

@@ -0,0 +1,35 @@
+{-# language FlexibleContexts #-}
+{-# language FlexibleInstances #-}
+{-# language MultiParamTypeClasses #-}
+module Hashed(Hashed, hashed, unhashed, HashTag(hashTagged)) where
+
+import Protolude
+
+import Text.Show
+
+import Data.Dependent.Sum
+
+class HashTag k v where
+  hashTagged :: k i -> v i -> Int
+
+data Hashed v i = Hashed !(v i) !Int
+  deriving (Show)
+
+instance Eq (v i) => Eq (Hashed v i) where
+  Hashed v1 h1 == Hashed v2 h2 = h1 == h2 && v1 == v2
+
+instance Ord (v i) => Ord (Hashed v i) where
+  compare (Hashed v1 _) (Hashed v2 _) = compare v1 v2
+
+instance Hashable (Hashed v i) where
+  hashWithSalt s (Hashed _ h) = hashWithSalt s h
+
+instance ShowTag k v => ShowTag k (Hashed v) where
+  showTaggedPrec k d (Hashed v _) = showParen (d > 10)
+    $ showString "Hashed " . showTaggedPrec k 11 v
+
+unhashed :: Hashed v i -> v i
+unhashed (Hashed x _) = x
+
+hashed :: HashTag k v => k i -> v i -> Hashed v i
+hashed k v = Hashed v $ hashTagged k v

src/Task.hs

@@ -0,0 +1,111 @@
+{-# language DeriveFunctor #-}
+{-# language RankNTypes #-}
+{-# language ScopedTypeVariables #-}
+module Task where
+
+import Protolude
+
+import Data.Dependent.Map(DMap, GCompare)
+import qualified Data.Dependent.Map as DMap
+import Data.Functor.Compose
+
+import Hashed
+import VerifyingTraces(VT)
+import qualified VerifyingTraces as VT
+
+data Env k v = Env
+  { tasks :: !(Tasks k v)
+  , tasksStartedVar :: !(MVar (DMap k (Compose MVar v)))
+  , taskTracesVar :: !(MVar (VT k v))
+  }
+
+newtype Task k v a = Task { unTask :: Env k v -> IO a }
+  deriving (Functor)
+
+type Tasks k v = forall i. k i -> Task k v (v i)
+
+runTask :: GCompare k => Tasks k v -> VT k v -> Task k v a -> IO (a, VT k v)
+runTask ts traces task = do
+  tracesVar <- newMVar traces
+  startedVar <- newMVar mempty
+  a <- unTask task Env
+    { tasks = ts
+    , tasksStartedVar = startedVar
+    , taskTracesVar = tracesVar
+    }
+  traces' <- readMVar tracesVar
+  return (a, traces')
+
+build :: (GCompare k, HashTag k v) => Tasks k v -> VT k v -> k i -> IO (v i, VT k v)
+build ts traces key = runTask ts traces $ fetch key
+
+instance Applicative (Task k v) where
+  pure = Task . pure . pure
+  Task f <*> Task x = Task $ (<*>) <$> f <*> x
+
+instance Monad (Task k v) where
+  Task ma >>= f = Task $ \env -> do
+    a <- ma env
+    unTask (f a) env
+
+instance MonadIO (Task k v) where
+  liftIO = Task . const
+
+track :: forall k v a. GCompare k => Task k v a -> Task k v (a, DMap k v)
+track (Task task) = Task $ \env -> do
+  depsVar <- newMVar mempty
+  let
+    tasks' :: forall i. k i -> Task k v (v i)
+    tasks' k = Task $ \_env -> do
+      v <- unTask (tasks env k) env
+      modifyMVar_ depsVar $ pure . DMap.insert k v
+      return v
+  a <- task env { tasks = tasks' }
+  deps <- readMVar depsVar
+  return (a, deps)
+
+fetchAsync :: (HashTag k v, GCompare k) => k i -> Task k v (Task k v (v i))
+fetchAsync key = Task $ \env -> do
+  var <- newEmptyMVar
+  _ <- forkIO $ do
+    value <- unTask (fetch key) env
+    putMVar var value
+  return $ liftIO $ readMVar var
+
+fetch :: (HashTag k v, GCompare k) => k i -> Task k v (v i)
+fetch key = Task $ \env -> do
+  putText "fetching"
+  let
+    fromScratch = do
+      putText "fromScratch"
+      (value, deps) <- unTask (track $ tasks env key) env
+      putText $ "deps " <> show (DMap.size deps)
+      modifyMVar_ (taskTracesVar env)
+        $ pure
+        . VT.record key value deps
+      return value
+
+    fetchHash k = hashed k <$> unTask (fetch k) env
+
+    checkDeps = do
+      taskTraces <- readMVar $ taskTracesVar env
+      case DMap.lookup key taskTraces of
+        Nothing -> fromScratch
+        Just oldValueDeps -> do
+          upToDate <- VT.verifyDependencies (VT.dependencies oldValueDeps) fetchHash
+          if upToDate then
+            return $ unhashed $ VT.value oldValueDeps
+          else
+            fromScratch
+
+  join $ modifyMVar (tasksStartedVar env) $ \tasksStarted ->
+    case DMap.lookup key tasksStarted of
+      Nothing -> do
+        valueVar <- newEmptyMVar
+        let k = do
+              value <- checkDeps
+              putMVar valueVar value
+              return value
+        return (DMap.insert key (Compose valueVar) tasksStarted, k)
+      Just (Compose valueVar) ->
+        return (tasksStarted, readMVar valueVar)