mad/byg/src/DependencyRunner.hs

module DependencyRunner
  ( DepRunM
  , runDeps
  , runDepRunMIO
  ) where

import Types (Value(..), fromValue, toValue, evalFunction, evalFunctionIO)
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

foo' :: [Value] -> [Value] -> [(Value, Value)]
foo' = zip

foo :: Value -> Value -> Value
foo va vb = toValue $ foo' (fromValue va) (fromValue vb)

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 $ toValue (va, vb)
  UZipToken a b -> do
    va <- getTokenValue a
    vb <- getTokenValue b
    pure $ foo va vb
  UListToken ts -> do
    vs <- mapM getTokenValue ts
    pure $ toValue vs
  UNoToken ->
    pure $ toValue ()

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 $ toValue $ evalFunction f $ fromValue input
  FunctionIO f ->
    liftIO (toValue <$> evalFunctionIO f (fromValue input))
  Inject v ->
    pure v
  FilterComp ->
    let (vs, mask) = fromValue input :: ([Value], [Value])
    in pure $ toValue $ map fst $ filter (fromValue . snd) $ zip vs mask
  UntupleFst ->
    pure $ fst (fromValue input :: (Value, Value))
  UntupleSnd ->
    pure $ snd (fromValue input :: (Value, Value))
  UnzipFst ->
    toValue <$> mapM (runAction UntupleFst) (fromValue input :: [Value])
  UnzipSnd ->
    toValue <$> mapM (runAction UntupleSnd) (fromValue input :: [Value])
  MapComp subDeps innerInput innerOutput ->
    (toValue <$>) $ forM (fromValue input :: [Value]) $ \v -> do
      putTokenValue innerInput $ Evaluated v
      runDeps subDeps
      getTokenValue innerOutput