mad/byg/src/Byg/DependencyRunner.hs

{-# LANGUAGE MonoLocalBinds #-}
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)