Pull instead of push

This commit is contained in:
Niels G. W. Serup 2024-10-06 00:40:54 +02:00
parent ed37ba9a09
commit a6ef299691
No known key found for this signature in database
GPG Key ID: 38EEEBCE67324F19
1 changed files with 31 additions and 16 deletions

View File

@ -11,10 +11,14 @@ import Evaluation.FunctionIO
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as M import qualified Data.Map as M
import Control.Monad (void)
import Control.Monad.State (MonadState, MonadIO, StateT, evalStateT, get, modify, liftIO) import Control.Monad.State (MonadState, MonadIO, StateT, evalStateT, get, modify, liftIO)
newtype DepRunM a = DepRunM { unDepRunM :: StateT (Map Int Value) IO a } data ValueExistence = Evaluated Value
deriving (Functor, Applicative, Monad, MonadIO, MonadState (Map Int Value)) | NotEvaluated (DepRunM Value)
newtype DepRunM a = DepRunM { unDepRunM :: StateT (Map Int ValueExistence) IO a }
deriving (Functor, Applicative, Monad, MonadIO, MonadState (Map Int ValueExistence))
runDeps :: [Dependency] -> DepRunM () runDeps :: [Dependency] -> DepRunM ()
runDeps = mapM_ runDep runDeps = mapM_ runDep
@ -22,22 +26,33 @@ runDeps = mapM_ runDep
runDepRunMIO :: DepRunM a -> IO a runDepRunMIO :: DepRunM a -> IO a
runDepRunMIO m = evalStateT (unDepRunM m) M.empty runDepRunMIO m = evalStateT (unDepRunM m) M.empty
evaluate :: ValueExistence -> DepRunM Value
evaluate = \case
Evaluated v -> pure v
NotEvaluated m -> m
runDep :: Dependency -> DepRunM () runDep :: Dependency -> DepRunM ()
runDep (Dependency a action b) = do runDep (Dependency a action b) =
if actionTouchesFilesystem action
then void m
else putTokenValue b $ NotEvaluated m
where m :: DepRunM Value
m = do
input <- getTokenValue a input <- getTokenValue a
result <- runAction action input result <- runAction action input
putTokenValue b result putTokenValue b $ Evaluated result
liftIO $ do liftIO $ do
putStrLn ("input: " ++ show input) putStrLn ("input: " ++ show input)
putStrLn ("action: " ++ show action) putStrLn ("action: " ++ show action)
putStrLn ("output: " ++ show result) putStrLn ("output: " ++ show result)
putStrLn "----------" putStrLn "----------"
pure result
getTokenValue :: UToken -> DepRunM Value getTokenValue :: UToken -> DepRunM Value
getTokenValue = \case getTokenValue = \case
UToken i -> do UToken i -> do
m <- get m <- get
pure (m M.! i) evaluate (m M.! i)
UTupleToken a b -> do UTupleToken a b -> do
va <- getTokenValue a va <- getTokenValue a
vb <- getTokenValue b vb <- getTokenValue b
@ -56,10 +71,10 @@ getTokenValue = \case
UNoToken -> UNoToken ->
pure Empty pure Empty
putTokenValue :: UToken -> Value -> DepRunM () putTokenValue :: UToken -> ValueExistence -> DepRunM ()
putTokenValue t v = case t of putTokenValue t e = case t of
UToken i -> UToken i ->
modify $ M.insert i v modify $ M.insert i e
UNoToken -> UNoToken ->
pure () pure ()
_ -> _ ->
@ -107,7 +122,7 @@ runAction action input = case action of
case input of case input of
List vs -> List vs ->
(List <$>) $ flip mapM vs $ \v -> do (List <$>) $ flip mapM vs $ \v -> do
putTokenValue innerInput v putTokenValue innerInput $ Evaluated v
runDeps subDeps runDeps subDeps
getTokenValue innerOutput getTokenValue innerOutput
_ -> _ ->