applicative-wired-value-with-builder.hs

Adds gimmie.hs

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

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

data Action f m a where
  Return :: a -> Action f m a
  Bind :: Action f m a -> (a -> Action f m b) -> Action f m b
  Action :: String -> f i -> (i -> m a) -> Action f m (f a)

instance Monad (Action f m) where return = pure; (>>=) = Bind
instance Applicative (Action f m) where (<*>) = ap; pure = Return
instance Functor (Action f m) where fmap = liftM

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

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

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

runIO :: Action Identity IO a -> IO a
runIO = \case
  Return a -> return a
  Bind m f -> runIO m >>= runIO . f
  Action name input act -> do
    putStrLn $ "Running " ++ name
    out <- act (runIdentity input)
    pure $ Identity out

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

newtype Value m a = Value { runValue :: Ap (Key m) a }
  deriving (Functor, Applicative)

data Key m a = Key { unKey :: String, gimmie :: m a }

graph :: Monad m => Action (Value m) m a -> State (Map String (Set String)) a
graph = \case
  Action string i m -> do
    modify (Map.insert string (keys i))
    pure $ Value $ liftAp $ Key {
      unKey = string,
      gimmie = val i >>= m
      }
  Bind m f -> graph m >>= graph . f
  Return a -> pure a

keys ::  Value m a -> Set String
keys = runAp_ (Set.singleton . unKey) . runValue

val :: Applicative m => Value m a -> m a
val = runAp gimmie . runValue

runValM :: Monad m => Action (Value m) m a -> m a
runValM = \case
  Return a -> return a
  Bind m f -> runValM m >>= runValM . f
  Action _name i m -> do
    val i >>= fmap pure . m

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

specific bit.hs

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

newtype Value m a = Value { runValue :: Ap (Key m) a }
  deriving (Functor, Applicative)

data Key m a = Key { unKey :: String, gimmie :: m a }

graph :: Monad m => Action (Value m) m a -> State (Map String (Set String)) a
graph = \case
  Action string i m -> do
    modify (Map.insert string (keys i))
    pure $ Value $ liftAp $ Key {
      unKey = string,
      gimmie = val i >>= m
      }
  Bind m f -> graph m >>= graph . f
  Return a -> pure a

keys ::  Value m a -> Set String
keys = runAp_ (Set.singleton . unKey) . runValue

val :: Applicative m => Value m a -> m a
val = runAp gimmie . runValue

runValM :: Monad m => Action (Value m) m a -> m a
runValM = \case
  Return a -> return a
  Bind m f -> runValM m >>= runValM . f
  Action _name i m -> do
    val i >>= fmap pure . m

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

-- =ghci> flip execState mempty $ graph example1
-- fromList [("read_file_1",fromList []),("read_file_2",fromList ["read_file_1"])]
--
-- =ghci> runValM example1 >>= val
-- ("file2.txt\n","Second file!\n")