final.hs

final.hs

{-# LANGUAGE KindSignatures, BlockArguments #-}
{-# language GADTs, LambdaCase, GeneralizedNewtypeDeriving #-}
import Data.Kind
import Data.Coerce
import Data.Functor.Const
import Control.Monad.Free
import Control.Applicative.Free
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Functor.Identity
import Data.ByteString (ByteString)
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Data.Set (Set)
import Control.Monad.Trans.State.Strict

--------------------------------------------------------------------------------
-- The applicative-wired monad pattern

data Spec f m a where
  Spec :: String -> f (m a) -> Spec f m (f a)

newtype Action f m a = Action { runAction :: Free (Ap (Spec f m)) a }
  deriving (Functor, Applicative, Monad)

act :: String -> f (m a) -> Action f m (f a)
act l f = Action $ liftF $ liftAp $ Spec l f

class Foreach f where
  foreach :: (Applicative m, Traversable t) => f (t x) -> (f x -> m (f b)) -> m (f (t b))

--------------------------------------------------------------------------------
-- An example

example :: (Applicative f, Foreach f) => Action f IO (f ([FilePath], [(ByteString,ByteString)]))
example = do
  files <- act "read_file_1" (pure $ fmap (lines . S8.unpack) $ S.readFile "file1.txt")
  fs <- foreach files \file -> do
    x <- act "x" (S.readFile <$> file)
    y <- act "y" (S.readFile <$> file)
    pure $ (,) <$> x <*> y
  pure $ (,) <$> pure [] <*> fs

--------------------------------------------------------------------------------
-- IO interpretation

instance Foreach Identity where
  foreach (Identity xs) f = Identity . fmap coerce <$> traverse (f . coerce) xs

runIO :: Action Identity IO a -> IO a
runIO = foldFree (runAp io) . runAction where
  io :: Spec Identity IO x -> IO x
  io = \case
    Spec name act' -> do
      putStrLn $ "Running " ++ name
      out <- runIdentity act'
      pure $ Identity out

--------------------------------------------------------------------------------
-- Graphable interpretation

newtype Value (a :: Type) = Value { runValue :: Const (Set String) a }
  deriving (Functor, Applicative)
instance Show (Value a) where
  show = show . keys

instance Foreach Value where
  foreach v f = fmap phantomList $ f $ phantomUnlist v

runGraph :: Applicative m => Action Value m (Value a) -> (Value a, Map String (Set String))
runGraph x = flip runState mempty $ graph $ do
  v <- x
  act "root" (pure <$> v)

graph :: Action Value m a -> State (Map String (Set String)) a
graph = foldFree (runAp go) . runAction where
  go :: Spec Value m a -> State (Map String (Set String)) a
  go = \case
   Spec string i -> do
    modify (Map.insert string (keys i))
    pure $ Value $ Const (Set.singleton string)

keys ::  Value a -> Set String
keys = getConst . runValue

phantomUnlist :: Value (t a) -> Value a
phantomUnlist = Value . Const . keys

phantomList :: Value a -> Value (t a)
phantomList = Value . Const . keys

-- Example:

-- -- Run as raw IO:

-- > runIO example
-- Running read_file_1
-- Running x
-- Running y
-- Identity ([],[("you found me\n","you found me\n")])

-- -- Dependency graph:

-- > runGraph example
-- (fromList ["root"],fromList [("read_file_1",fromList []),("root",fromList ["x","y"]),("x",fromList ["read_file_1"]),("y",fromList ["read_file_1"])])