mad/byg/src/DependencyRunner.hs

{-# LANGUAGE MonoLocalBinds #-}
module DependencyRunner
  ( DepRunM
  , runDeps
  , runDepRunMIO
  ) where

import Types (evalFunction, evalFunctionIO)
import Types.Value
import Types.Token
import Types.Dependency

import Data.Map (Map)
import qualified Data.Map as M
import Control.Monad (void, forM)
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 :: Token a -> DepRunM Value
getTokenValue token = case token of
  Token i -> do
    m <- get
    evaluate (m M.! i)
  TupleToken a b -> do
    va <- getTokenValue a
    vb <- getTokenValue b
    pure $ toValueRep (tokenTypeRep token) (fromValue va, fromValue vb)
  ZipToken a b -> do
    va <- getTokenValue a
    vb <- getTokenValue b
    pure $ toValueRep (tokenTypeRep token) $ zip (fromValue va) (fromValue vb)
  ListToken ts -> do
    vs <- mapM getTokenValue ts
    pure $ toValueRep (tokenTypeRep token) (map fromValue vs)
  NoToken ->
    pure $ toValue ()

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

runAction :: Action a b -> Value -> DepRunM Value
runAction action input = case action of
  Function f ->
    pure $ toValue $ evalFunction f $ fromValue input
  InlineFunction (F f) ->
    pure $ toValue $ f $ fromValue input
  FunctionIO f ->
    liftIO (toValue <$> evalFunctionIO f (fromValue input))
  Inject x ->
    pure $ toValue x
  FilterComp ->
    let (vs, mask) = fromValue input
    in pure $ toValueRep (actionTargetType action) $ map fst $ filter snd $ zip vs mask
  UntupleFst ->
    pure $ toValue $ fst $ fromValueRep (actionSourceType action) input
  UntupleSnd ->
    pure $ toValue $ snd $ fromValueRep (actionSourceType action) input
  UnzipFst ->
    pure $ toValue $ map fst $ fromValueRep (actionSourceType action) input
  UnzipSnd ->
    pure $ toValue $ map snd $ fromValueRep (actionSourceType action) input
  MapComp subDeps innerInput innerOutput ->
    (toValueRep (actionTargetType action) <$>) $ forM (fromValueRep (actionSourceType action) input) $ \x -> do
      putTokenValue innerInput $ Evaluated $ toValue x
      runDeps subDeps
      fromValue <$> getTokenValue innerOutput