274 lines
9.9 KiB
Haskell
274 lines
9.9 KiB
Haskell
{-# LANGUAGE MonoLocalBinds #-}
|
|
|
|
-- | Run the actual operations from the generated dependencies from DependencyGenerator.
|
|
--
|
|
-- This does not work fully as intended right now (computes more than strictly
|
|
-- needed) and needs to be rewritten in a more testable way. The idea is to only
|
|
-- evaluate something if a future operation depends on it, which is reflected in
|
|
-- the ValueExistence type.
|
|
module Byg.DependencyRunner
|
|
( DepRunM
|
|
, runDeps
|
|
, runDepRunMIO
|
|
, extractSndToken
|
|
, extractSndTokenAsList
|
|
) where
|
|
|
|
import Byg.Types (evalFunctionIO, functionIOReads, functionIOWrites)
|
|
import Byg.Types.Value
|
|
import Byg.Types.Token
|
|
import Byg.Types.Dependency
|
|
|
|
import Type.Reflection (Typeable)
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as M
|
|
import Control.Monad (void, forM, filterM)
|
|
import Control.Monad.State (MonadState, MonadIO, StateT, evalStateT, get, modify, liftIO)
|
|
import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell)
|
|
import System.Directory (getModificationTime)
|
|
import Data.Time.Clock (UTCTime(..))
|
|
import qualified System.Directory as SD
|
|
|
|
data LastUpdated = Never
|
|
| NeverDebug String
|
|
| NeverInput
|
|
| At UTCTime
|
|
deriving (Show, Eq, Ord)
|
|
|
|
data ValueExistence = Evaluated Value LastUpdated
|
|
| NotEvaluated (LastUpdated -> DepRunM (Maybe (Value, LastUpdated)))
|
|
|
|
newtype DepRunM a = DepRunM { unDepRunM :: WriterT [FilePath] (StateT (Map Int ValueExistence) IO) a }
|
|
deriving (Functor, Applicative, Monad, MonadIO,
|
|
MonadState (Map Int ValueExistence),
|
|
MonadWriter [FilePath])
|
|
|
|
runDeps :: [Dependency] -> DepRunM ()
|
|
runDeps = mapM_ runDep
|
|
|
|
runDepRunMIO :: DepRunM a -> IO (a, [FilePath])
|
|
runDepRunMIO m = evalStateT (runWriterT (unDepRunM m)) M.empty
|
|
|
|
evaluate :: LastUpdated -> ValueExistence -> DepRunM (Maybe (Value, LastUpdated))
|
|
evaluate luFuture = \case
|
|
Evaluated v lu -> pure (Just (v, lu))
|
|
NotEvaluated m -> m luFuture
|
|
|
|
runDep :: Dependency -> DepRunM ()
|
|
runDep (Dependency _ a action _ b) =
|
|
if actionWritesAny action
|
|
then void (m Never)
|
|
else putTokenValue b $ NotEvaluated m
|
|
where m :: LastUpdated -> DepRunM (Maybe (Value, LastUpdated))
|
|
m luFuture = do
|
|
mr <- runAction action a luFuture
|
|
case mr of
|
|
Just (result, luResult) -> do
|
|
putTokenValue b $ Evaluated result luResult
|
|
pure $ Just (result, luResult)
|
|
Nothing ->
|
|
pure Nothing
|
|
|
|
extractSndToken :: Token (a, b) -> Token b
|
|
extractSndToken = \case
|
|
TupleToken _ b ->
|
|
b
|
|
_ ->
|
|
error "unsupported"
|
|
|
|
extractSndTokenAsList :: (Show b, Typeable b) => Token (a, b) -> Token [b]
|
|
extractSndTokenAsList = ListToken . (: []) . extractSndToken
|
|
|
|
getTokenValueByIndex :: LastUpdated -> Int -> DepRunM (Maybe (Value, LastUpdated))
|
|
getTokenValueByIndex luFuture i = do
|
|
m <- get
|
|
case m M.!? i of
|
|
Nothing -> pure Nothing
|
|
Just x -> evaluate luFuture x
|
|
|
|
-- minimumOrNever :: [LastUpdated] -> LastUpdated
|
|
-- minimumOrNever = \case
|
|
-- [] -> Never
|
|
-- times -> minimum times
|
|
|
|
maximumOrNever :: [LastUpdated] -> LastUpdated
|
|
maximumOrNever = \case
|
|
[] -> Never
|
|
times -> maximum times
|
|
|
|
maximumOrNever' :: [UTCTime] -> LastUpdated
|
|
maximumOrNever' = maximumOrNever . map At
|
|
|
|
getTokenValueRaw :: LastUpdated -> Token a -> DepRunM (Maybe (a, LastUpdated))
|
|
getTokenValueRaw luFuture token = case token of
|
|
Token i -> do
|
|
m <- getTokenValueByIndex luFuture i
|
|
pure $ do (a, lu) <- m
|
|
pure (fromValue a, lu)
|
|
|
|
TupleToken a b -> do
|
|
m0 <- getTokenValueRaw luFuture a
|
|
m1 <- getTokenValueRaw luFuture b
|
|
case (m0, m1) of
|
|
(Just (a', luA), Just (b', luB)) ->
|
|
pure $ Just ((a', b'), max luA luB)
|
|
(Just (a', luA), Nothing) -> do -- | luA /= NeverInput -> do
|
|
r <- getTokenValueRaw (NeverDebug (show (a', luA))) b
|
|
pure $ case r of
|
|
Nothing -> error ("unexpected " ++ show b ++ " (" ++ show (a', luA) ++ ")")
|
|
Just (b', luB) -> Just ((a', b'), max luA luB)
|
|
(Nothing, Just (b', luB)) -> do -- | luB /= NeverInput -> do
|
|
r <- getTokenValueRaw (NeverDebug (show (b', luB))) a
|
|
pure $ case r of
|
|
Nothing -> error "unexpected"
|
|
Just (a', luA) -> Just ((a', b'), max luA luB)
|
|
_ ->
|
|
pure $ Nothing
|
|
|
|
ZipToken a b -> do
|
|
m0 <- getTokenValueRaw luFuture a
|
|
m1 <- getTokenValueRaw luFuture b
|
|
case (m0, m1) of
|
|
(Just (a', luA), Just (b', luB)) ->
|
|
pure $ Just (zip a' b', max luA luB)
|
|
(Just (a', luA), Nothing) -> do -- | luA /= NeverInput -> do
|
|
r <- getTokenValueRaw Never b
|
|
pure $ case r of
|
|
Nothing -> error "unexpected"
|
|
Just (b', luB) -> Just (zip a' b', max luA luB)
|
|
(Nothing, Just (b', luB)) -> do -- | luB /= NeverInput -> do
|
|
r <- getTokenValueRaw Never a
|
|
pure $ case r of
|
|
Nothing -> error "unexpected"
|
|
Just (a', luA) -> Just (zip a' b', max luA luB)
|
|
_ ->
|
|
pure $ Nothing
|
|
|
|
ListToken ts -> do
|
|
ms <- mapM (getTokenValueRaw luFuture) ts
|
|
if False -- null $ filter ((/= NeverInput) . snd) (catMaybes ms)
|
|
then pure Nothing
|
|
else do ms' <- case sequence ms of
|
|
Just x -> pure x
|
|
Nothing -> do r <- mapM (getTokenValueRaw Never) ts
|
|
case sequence r of
|
|
Nothing -> error "unexpected"
|
|
Just x -> pure x
|
|
let (as, lus) = unzip ms'
|
|
pure $ Just (as, maximumOrNever lus)
|
|
|
|
NoToken ->
|
|
pure $ Just ((), Never)
|
|
|
|
getTokenValue :: Token a -> LastUpdated -> DepRunM (Maybe (Value, LastUpdated))
|
|
getTokenValue token luFuture = case token of
|
|
Token i ->
|
|
getTokenValueByIndex luFuture i
|
|
TupleToken _ _ ->
|
|
fromRaw token
|
|
ZipToken _ _ ->
|
|
fromRaw token
|
|
ListToken _ ->
|
|
fromRaw token
|
|
NoToken ->
|
|
fromRaw token
|
|
where fromRaw :: (Typeable a, Show a) => Token a -> DepRunM (Maybe (Value, LastUpdated))
|
|
fromRaw t = do
|
|
m <- getTokenValueRaw luFuture t
|
|
pure $ do (x, lu) <- m
|
|
pure (toValue x, lu)
|
|
|
|
putTokenValue :: Token a -> ValueExistence -> DepRunM ()
|
|
putTokenValue t v = case t of
|
|
Token i ->
|
|
modify $ M.insert i v
|
|
NoToken ->
|
|
pure ()
|
|
_ ->
|
|
error "unexpected"
|
|
|
|
maximumModTime :: [FilePath] -> DepRunM LastUpdated
|
|
maximumModTime paths = do
|
|
paths' <- filterM (liftIO . SD.doesPathExist) paths
|
|
times <- mapM (liftIO . getModificationTime) paths'
|
|
pure $ maximumOrNever' times
|
|
|
|
runAction :: forall a b. Action a b -> Token a -> LastUpdated
|
|
-> DepRunM (Maybe (Value, LastUpdated))
|
|
runAction action tokenInput luFuture = case action of
|
|
Function (F f) ->
|
|
calc f
|
|
FunctionIO f -> do
|
|
m <- getTokenValueRaw luFuture $ functionIOWrites f tokenInput
|
|
case m of
|
|
Nothing ->
|
|
pure Nothing -- error "unexpected" -- wrong?
|
|
Just (writes, _writesLu) -> do
|
|
tell writes
|
|
lastWritten <- max luFuture <$> maximumModTime writes
|
|
result <- getTokenValue tokenInput lastWritten
|
|
case result of
|
|
Just (inputValue, luInput) -> do
|
|
let input = inputFromValue inputValue
|
|
lastUpdated <- max luInput <$> (maximumModTime $ functionIOReads f input)
|
|
if lastUpdated > lastWritten
|
|
then do liftIO $ do
|
|
putStrLn ("input: " ++ show input)
|
|
putStrLn ("input last updated: " ++ show luInput)
|
|
putStrLn ("IO function: " ++ show f)
|
|
putStrLn ("Source timestamp: " ++ show lastUpdated)
|
|
putStrLn ("Target timestamp: " ++ show lastWritten)
|
|
v <- toValue <$> (liftIO $ evalFunctionIO f input)
|
|
-- tell writes
|
|
let luResult = max luInput lastUpdated
|
|
liftIO $ do
|
|
putStrLn ("output: " ++ show v)
|
|
putStrLn ("output last updated: " ++ show luResult)
|
|
putStrLn "----------"
|
|
pure $ Just (v, luResult)
|
|
else do -- liftIO $ putStrLn ("Source timestamp "
|
|
-- ++ show lastUpdated
|
|
-- ++ " not newer than target timestamp "
|
|
-- ++ show lastWritten
|
|
-- ++ "; ignoring IO computation.")
|
|
pure Nothing -- (toValue (), lastWritten) -- assumes writing FunctionIO always return ()
|
|
Nothing ->
|
|
pure Nothing
|
|
Inject x ->
|
|
pure $ Just (toValue x, NeverInput)
|
|
FilterComp ->
|
|
calc (\(vs, mask) -> map fst $ filter snd $ zip vs mask)
|
|
UntupleFst ->
|
|
calc fst
|
|
UntupleSnd ->
|
|
calc snd
|
|
UnzipFst ->
|
|
calc (map fst)
|
|
UnzipSnd ->
|
|
calc (map snd)
|
|
MapComp subDeps innerInput innerOutput -> do
|
|
m <- getTokenValue tokenInput luFuture
|
|
case m of
|
|
Nothing -> pure Nothing
|
|
Just (inputValue, luInput) -> do
|
|
let input = inputFromValue inputValue
|
|
lastUpdated <- maximumModTime $ actionReads action input
|
|
result <- forM input $ \x -> do
|
|
putTokenValue innerInput $ Evaluated (toValue x) (max luInput lastUpdated)
|
|
runDeps subDeps
|
|
mr <- getTokenValue innerOutput luFuture
|
|
pure $ do (vOut, luOut) <- mr
|
|
pure (fromValue vOut, luOut)
|
|
pure $ do result' <- sequence result
|
|
let (values, lus) = unzip result'
|
|
pure $ (toValueRep (actionTargetType action) values, maximumOrNever lus)
|
|
where inputFromValue :: Typeable a => Value -> a
|
|
inputFromValue = fromValueRep (actionSourceType action)
|
|
|
|
calc :: (Typeable a, Typeable b, Show b) => (a -> b) -> DepRunM (Maybe (Value, LastUpdated))
|
|
calc f = do
|
|
m <- getTokenValue tokenInput luFuture
|
|
pure $ do (inputValue, luInput) <- m
|
|
let input = inputFromValue inputValue
|
|
pure (toValue $ f input, luInput)
|