sweet.hs

sweet.hs

{-# LANGUAGE KindSignatures, BlockArguments #-}
{-# language GADTs, LambdaCase, GeneralizedNewtypeDeriving #-}
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 Applicative f => Foreach f where
  foreach :: Applicative m => f [x] -> (f x -> Action f m (f b)) -> Action f m (f [b])

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

example :: 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 runIdentity <$> traverse (\x -> f (Identity x)) 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 = Value { runValue :: Ap Keys a }
  deriving (Functor, Applicative)
instance Show (Value a) where
  show = show . keys

data Keys a = Keys { unKeys :: Set String }

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 $ liftAp $ Keys (Set.singleton string)

keys ::  Value a -> Set String
keys = runAp_ unKeys . runValue

phantomUnlist :: Value [a] -> Value a
phantomUnlist = Value . liftAp . Keys . keys

phantomList :: Value a -> Value [a]
phantomList = Value . liftAp . Keys . keys

-- Example:

-- -- Run as raw IO:

-- > runIO example
-- Running read_file_1
-- Running read_file_2
-- Identity ("file2.txt\n","Second file!\n")

-- -- Dependency graph:

-- > runGraph example
-- fromList [("read_file_1",fromList []),("read_file_2",fromList ["read_file_1"])]