Pull instead of push
This commit is contained in:
parent
ed37ba9a09
commit
a6ef299691
|
@ -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
|
||||||
_ ->
|
_ ->
|
||||||
|
|
Loading…
Reference in New Issue