blog.hs

blog.hs

{-# LANGUAGE KindSignatures, BlockArguments #-}
{-# language GADTs, LambdaCase, GeneralizedNewtypeDeriving #-}
import Data.Kind
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

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

example :: Applicative f => Action f IO (f (ByteString, ByteString))
example = do
  file1 <- act "read_file_1" (pure $ S.readFile "file1.txt")
  file2 <- act "read_file_2" (S.readFile .  unwords . words . S8.unpack <$> file1)
  pure $ (,) <$> file1 <*> file2

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

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

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

-- Example:

-- -- Run as raw IO:

-- > runIO example
-- Running read_file_1
-- Running read_file_2
-- Identity ("hello.txt\n","you found me\n")

-- -- Dependency graph:

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