mad/byg/src/DependencyRunner.hs

module DependencyRunner
  ( DepRunM
  , runDeps
  , runDepRunMIO
  ) where

import Types (Value(..), fromValue, evalFunctionIO)
import Types.Dependency
import Evaluation.Function

import Data.Map (Map)
import qualified Data.Map as M
import Control.Monad (void)
import Control.Monad.State (MonadState, MonadIO, StateT, evalStateT, get, modify, liftIO)

data ValueExistence = Evaluated 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 = mapM_ runDep

runDepRunMIO :: DepRunM a -> IO a
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 a action b) =
  if actionTouchesFilesystem action
  then void m
  else putTokenValue b $ NotEvaluated m
  where m :: DepRunM Value
        m = do
          input <- getTokenValue a
          result <- runAction action input
          putTokenValue b $ Evaluated result
          liftIO $ do
            putStrLn ("input: " ++ show input)
            putStrLn ("action: " ++ show action)
            putStrLn ("output: " ++ show result)
            putStrLn "----------"
          pure result

getTokenValue :: UToken -> DepRunM Value
getTokenValue = \case
  UToken i -> do
    m <- get
    evaluate (m M.! i)
  UTupleToken a b -> do
    va <- getTokenValue a
    vb <- getTokenValue b
    pure $ Tuple (va, vb)
  UZipToken a b -> do
    va <- getTokenValue a
    vb <- getTokenValue b
    case (va, vb) of
      (List as, List bs) ->
        pure $ List $ zipWith (curry Tuple) as bs
      _ ->
        error "unexpected"
  UListToken ts -> do
    vs <- mapM getTokenValue ts
    pure $ List vs
  UNoToken ->
    pure Empty

putTokenValue :: UToken -> ValueExistence -> DepRunM ()
putTokenValue t e = case t of
  UToken i ->
    modify $ M.insert i e
  UNoToken ->
    pure ()
  _ ->
    error "unexpected"

runAction :: Action -> Value -> DepRunM Value
runAction action input = case action of
  Function f ->
    pure $ evalFunction f input
  FunctionIO f ->
    liftIO $ evalFunctionIO f input
  Inject v ->
    pure v
  FilterComp ->
    case input of
      Tuple (List vs, List mask) ->
        pure $ List $ map fst $ filter (fromValue . snd) $ zip vs mask
      _ ->
        error "unexpected"
  UntupleFst ->
    case input of
      Tuple (v, _) ->
        pure v
      _ ->
        error "unexpected"
  UntupleSnd ->
    case input of
      Tuple (_, v) ->
        pure v
      _ ->
        error "unexpected"
  UnzipFst ->
    case input of
      List vs ->
        List <$> mapM (runAction UntupleFst) vs
      _ ->
        error "unexpected"
  UnzipSnd ->
    case input of
      List vs ->
        List <$> mapM (runAction UntupleSnd) vs
      _ ->
        error "unexpected"
  MapComp subDeps innerInput innerOutput ->
    case input of
      List vs ->
        (List <$>) $ flip mapM vs $ \v -> do
          putTokenValue innerInput $ Evaluated v
          runDeps subDeps
          getTokenValue innerOutput
      _ ->
        error "unexpected"