Precise flow control in Haskell

Question

The Idea

Hello! I'm trying to implement in Haskell an image processing library based on dataflow ideology. I've got a problem connected to how I want to handle the flow of control.

The main idea is to introduce a time. The time is a Float, which could be accessed anywhere in the code (you can think of it like about State monad, but a little funnier). The funny thing about it, is that we can use timeShift operation on results, affecting the time corresponding operations would see.

An example would be best to explain this situation. Lets use following dataflow diagram:

--               timeShift(*2) -- --              /                 \ -- readImage --                    addImages -> out --              \                 / --                blur ---------- 

and its pseudocode (which deos not typecheck - its not important if we use do or let notation here, the idea should be clear):

test = do     f      <- frame     a      <- readImage $ "test" + show f + ".jpg"     aBlur  <- blur a     a'     <- a.timeShift(*2)     out    <- addImage aBlur a'  main = print =<< runStateT test 5 

The 5 is the time we want to run the test function with. The timeShift function affects all the operations on the left of it (in the dataflow diagram) - in this case the function readImage would be run twice - for both branches - the lower one would use frame 5 and the upper one frame 5*2 = 10.

The problem

I'm providing here a very simple implementation, that works great, but has some caveats I want to solve. The problem is, that I want to keep the order of all IO operations. Look at the bottom for example, which will clarify what I mean.

Sample implementation

Below is a sample implementation of the algorithm and a code, which constructs following dataflow graph:

-- A --- blur --- timeShift(*2) -- --                                \ --                                 addImages -> out --                                / -- B --- blur -------------------- 

the code:

import Control.Monad.State  -- for simplicity, lets assume an Image is just a String type Image = String  imagesStr = ["a0","b1","c2","d3","e4","f5","g6","h7","i8","j9","k10","l11","m12","n13","o14","p15","q16","r17","s18","t19","u20","v21","w22","x23","y24","z25"] images = "abcdefghjiklmnoprstuwxyz"  -------------------------------- -- Ordinary Image processing functions  blurImg' :: Image -> Image blurImg' img = "(blur " ++ img ++ ")"  addImage' :: Image -> Image -> Image addImage' img1 img2 = "(add " ++ img1 ++ " " ++ img2 ++ ")"  -------------------------------- -- Functions processing Images in States  readImage1 :: StateT Int IO Image readImage1 = do     t <- get     liftIO . putStrLn $ "[1] reading image with time: " ++ show t     return $ imagesStr !! t  readImage2 :: StateT Int IO Image readImage2 = do     t <- get     liftIO . putStrLn $ "[2] reading image with time: " ++ show t     return $ imagesStr !! t  blurImg :: StateT Int IO Image -> StateT Int IO Image blurImg img = do     i <- img     liftIO $ putStrLn "blurring"     return $ blurImg' i  addImage :: StateT Int IO Image -> StateT Int IO Image -> StateT Int IO Image addImage img1 img2 = do     i1 <- img1     i2 <- img2     liftIO $ putStrLn "adding images"     return $ addImage' i1 i2   timeShift :: StateT Int IO Image -> (Int -> Int) -> StateT Int IO Image timeShift img f = do     t <- get     put (f t)     i <- img     put t     return i  test = out where     i1   = readImage1     j1   = readImage2      i2   = blurImg i1     j2   = blurImg j1      i3   = timeShift i2 (*2)     out  = addImage i3 j2   main = do     print =<< runStateT test 5     print "end" 

The output is:

[1] reading image with time: 10 blurring [2] reading image with time: 5 blurring adding images ("(add (blur k10) (blur f5))",5) "end" 

and should be:

[1] reading image with time: 10 [2] reading image with time: 5 blurring blurring adding images ("(add (blur k10) (blur f5))",5) "end" 

Please note that the correct output is ("(add (blur k10) (blur f5))",5) - which means, that we added image k10 to f5 - from respectively 10th and 5th frame.

Further requirements I'm looking for a solution, which would allow users to write simple code (like in test function - it could of course be in a Monad), but I do not want them to handle the time-shifting logic by hand.

Conclusions

The only difference is the order of IO actions execution. I would love to preserve the order of the IO actions just like they are written in the test function. I was trying to implement the idea using Countinuations, Arrows and some funny states, but without success.

Answer 1

Dataflow and functional reactive programming libraries in Haskell are usually written in terms of Applicative or Arrow. These are abstractions for computations that are less general than Monads - the Applicative and Arrow typeclasses do not expose a way for the structure of computations to depend on the results of other computations. As a result, libraries exposing only these typeclasses can reason about the structure of computations in the library independently of performing those computations. We will solve your problem in terms of the Applicative typeclass

class Functor f => Applicative f where     -- | Lift a value.     pure :: a -> f a         -- | Sequential application.     (<*>) :: f (a -> b) -> f a -> f b 

Applicative allows a library user to make new computations with pure, operate on existing computations with fmap (from Functor) and compose computations together with <*>, using the result of one computation as an input for another. It does not allow a library user to make a computation that makes another computation and then use the result of that computation directly; there's no way a user can write join :: f (f a) -> f a. This restriction will keep our library from running into the problem I described in my other answer.

Transformers, free, and the ApT transformer

Your example problem is quite involved, so we are going to pull out a bunch of high level Haskell tricks, and make a few new ones of our own. The first two tricks we are going to pull out are transformers and free data types. Transformers are types that take types with a kind like that of Functors, Applicatives or Monads and produce new types with the same kind.

Transformers typically look like the following Double example. Double can take any Functor or Applicative or Monad and make a version of it that always holds two values instead of one

newtype Double f a = Double {runDouble :: f (a, a)} 

Free data types are transformers that do two things. First, given some simpler property of the underlying type the gain new exciting properties for the transformed type. The Free Monad provides a Monad given any Functor, and the free Applicative, Ap, makes an Applicative out of any Functor. The other thing "free" types do is they "free" the implementation of the interpreter as much as possible. Here are the types for the free Applicative, Ap, the free Monad, Free, and the free monad transfomer, FreeT. The free monad transformer provides a monad transformer for "free" given a Functor

-- Free Applicative data Ap f a where     Pure :: a -> Ap f a     Ap   :: f a -> Ap f (a -> b) -> Ap f b  -- Base functor of the free monad transformer data FreeF f a b     = Pure a         | Free (f b)      -- Free monad transformer newtype FreeT f m a = FreeT {runFreeT :: m (FreeF f a (FreeT f m a)}  -- The free monad is the free monad transformer applied to the Identity monad type Free f = FreeT f Identity 

Here's a sketch of our goal - we want to provide an Applicative interface for combining computations, which, at the bottom, allows Monadic computations. We want to "free" the interpreter as much as possible so that it can hopefully reorder computations. To do this, we will be combining both the free Applicative and the free monad transformer.

We want an Applicative interface, and the easiest one to make is the one we can get for "free", which aligns nicely with out goal of "freeing the interpeter" as much as possible. This suggests our type is going to look like

Ap f a 

for some Functor f and any a. We'd like the underlying computation to be over some Monad, and Monads are functors, but we'd like to "free" the interpreter as much as posssible. We'll grab the free monad transformer as the underlying functor for Ap, giving us

Ap (FreeT f m) a 

for some Functor f, some Monad m, and any a. We know the Monad m is probably going to be IO, but we'll leave our code as generic as possible. We just need to provide the Functor for FreeT. All Applicatives are Functors, so Ap itself could be used for f, we'd write something like

type ApT m a = Ap (FreeT (ApT m) m) a 

This gives the compiler fits, so instead we'll mover the Ap inside and define

newtype ApT m a = ApT {unApT :: FreeT (Ap (ApT m)) m a} 

We'll derive some instances for this and discuss its real motivation after an interlude.

Interlude

To run all of this code, you'll need the following. The Map and Control.Concurrent are only needed for sharing computations, more on that much later.

{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Main where  import Control.Monad.Trans.Class import Control.Monad.IO.Class  import Control.Monad.Trans.Reader import Control.Applicative  import Control.Applicative.Free hiding (Pure) import qualified Control.Applicative.Free as Ap (Ap(Pure)) import Control.Monad.Trans.Free  import qualified Data.Map as Map import Control.Concurrent 

Stuffing it

I mislead you in the previous section, and pretended to discover ApT from resoning about the problem. I actually discovered ApT by trying anything and everything to try to stuff Monadic computations into an Applicative and be able to control their order when it came out. For a long time, I was trying to solve how to implement mapApM (below) in order to write flipImage (my replacement for your blur). Here's the ApT Monad transformer in all its glory. It's intended to be used as the Functor for an Ap, and, by using Ap as its own Functor for FreeT, can magically stuff values into an Applicative that shouldn't seem possible.

newtype ApT m a = ApT {unApT :: FreeT (Ap (ApT m)) m a}      deriving (Functor, Applicative, Monad, MonadIO) 

It could derive even more instances from FreeT, these are just the ones we need. It can't derive MonadTrans, but we can do that ourselves:

instance MonadTrans ApT where     lift = ApT . lift  runApT :: ApT m a -> m (FreeF (Ap (ApT m)) a (FreeT (Ap (ApT m)) m a)) runApT = runFreeT . unApT 

The real beauty of ApT is we can write some seemingly impossible code like

stuffM :: (Functor m, Monad m) => m (ApT m a) -> ApT m a stuffMAp :: (Functor m, Monad m) => m (ApT m a) -> Ap (ApT m) a 

The m on the outside disappeares, even into Ap that's merely Applicative.

This works because of the following cycle of functions, each of which can stuff the output from the function above it into the input of the function below it. The first function starts with an ApT m a, and the last one ends with one. (These definitions aren't part of the program)

liftAp' :: ApT m a ->            Ap (ApT m) a liftAp' = liftAp  fmapReturn :: (Monad m) =>                Ap (ApT m) a ->                Ap (ApT m) (FreeT (Ap (ApT m)) m a) fmapReturn = fmap return  free' :: Ap (ApT m) (FreeT (Ap (ApT m)) m a) ->          FreeF (Ap (ApT m)) a (FreeT (Ap (ApT m)) m a) free' = Free  pure' :: a ->          FreeF (Ap (ApT m)) a (FreeT (Ap (ApT m)) m a) pure' = Pure  return' :: (Monad m) =>            FreeF (Ap (ApT m)) a (FreeT (Ap (ApT m)) m a) ->            m (FreeF (Ap (ApT m)) a (FreeT (Ap (ApT m)) m a)) return' = return  freeT :: m (FreeF (Ap (ApT m)) a (FreeT (Ap (ApT m)) m a)) ->          FreeT (Ap (ApT m)) m a freeT = FreeT  apT :: FreeT (Ap (ApT m)) m a ->        ApT m a apT = ApT 

This lets us write

-- Get rid of an Ap by stuffing it into an ApT. stuffAp :: (Monad m) => Ap (ApT m) a -> ApT m a stuffAp = ApT . FreeT . return . Free . fmap return  -- Stuff ApT into Free stuffApTFree :: (Monad m) => ApT m a -> FreeF (Ap (ApT m)) a (FreeT (Ap (ApT m)) m a) stuffApTFree = Free . fmap return . liftAp  -- Get rid of an m by stuffing it into an ApT stuffM :: (Functor m, Monad m) => m (ApT m a) -> ApT m a stuffM = ApT . FreeT . fmap stuffApTFree  -- Get rid of an m by stuffing it into an Ap stuffMAp :: (Functor m, Monad m) => m (ApT m a) -> Ap (ApT m) a stuffMAp = liftAp . stuffM 

And some utility functions for working on a transformer stack

mapFreeT :: (Functor f, Functor m, Monad m) => (m a -> m b) -> FreeT f m a -> FreeT f m b mapFreeT f fa = do     a <- fa     FreeT . fmap Pure . f . return $ a  mapApT :: (Functor m, Monad m) => (m a -> m b) -> ApT m a -> ApT m b mapApT f = ApT . mapFreeT f . unApT  mapApM :: (Functor m, Monad m) => (m a -> m b) -> Ap (ApT m) a -> Ap (ApT m) b mapApM f = liftAp . mapApT f . stuffAp 

We'd like to start writing our example image processors, but first we need to take another diversion to address a hard requirement.

A hard requirement - input sharing

Your first example shows

--               timeShift(*2) -- --              /                 \ -- readImage --                    addImages -> out --              \                 / --                blur ---------- 

implying that the result of readImage should be shared between blur and timeShift(*2). I take this to mean that the results of readImage should only be computed once for each time.

Applicative isn't powerful enough to capture this. We'll make a new typeclass to represent computations whose output can be divided into multiple identical streams.

-- The class of things where input can be shared and divided among multiple parts class Applicative f => Divisible f where     (<\>) :: (f a -> f b) -> f a -> f b 

We'll make a transformer that adds this capability to existing Applicatives

-- A transformer that adds input sharing data LetT f a where     NoLet :: f a -> LetT f a     Let   :: LetT f b -> (LetT f b -> LetT f a) -> LetT f a 

And provide some utility functions and instances for it

-- A transformer that adds input sharing data LetT f a where     NoLet :: f a -> LetT f a     Let   :: LetT f b -> (LetT f b -> LetT f a) -> LetT f a  liftLetT :: f a -> LetT f a liftLetT = NoLet  mapLetT :: (f a -> f b) -> LetT f a -> LetT f b mapLetT f = go     where         go (NoLet a) = NoLet (f a)         go (Let b g) = Let b (go . g)  instance (Applicative f) => Functor (LetT f) where     fmap f = mapLetT (fmap f)  -- I haven't checked that these obey the Applicative laws. instance (Applicative f) => Applicative (LetT f) where     pure = NoLet . pure     NoLet f <*> a = mapLetT (f <*>) a     Let c h <*> a = Let c ((<*> a) . h)     instance (Applicative f) => Divisible (LetT f) where     (<\>) = flip Let 

Image processors

With all of our transformers in place, we can start writing our image processors. At the bottom of our stack we have our ApT from an earlier section

Ap (ApT IO) 

The computations need to be able to read the time from the environment, so we'll add a ReaderT for that

ReaderT Int (Ap (ApT IO)) 

Finally, we'd like to be able to share computations, so we'll add out LetT transformer on top, giving the entire type IP for our image processors

type Image = String type IP = LetT (ReaderT Int (Ap (ApT IO))) 

We'll read images from IO. getLine makes fun interactive examples.

readImage :: Int -> IP Image readImage n = liftLetT $ ReaderT (\t -> liftAp . liftIO $ do     putStrLn $  "[" ++ show n ++ "] reading image for time: " ++ show t     --getLine     return $ "|image [" ++ show n ++ "] for time: " ++ show t ++ "|"     ) 

We can shift the time of inputs

timeShift :: (Int -> Int) -> IP a -> IP a timeShift f = mapLetT shift     where         shift (ReaderT g) = ReaderT (g . f)   

Add multiple images together

addImages :: Applicative f => [f Image] -> f Image addImages = foldl (liftA2 (++)) (pure []) 

And flip images pretending to use some library that's stuck in IO. I couldn't figure out how to blur a string...

inIO :: (IO a -> IO b) -> IP a -> IP b inIO = mapLetT . mapReaderT . mapApM          flipImage :: IP [a] -> IP [a] flipImage = inIO flip'     where         flip' ma = do             a <- ma             putStrLn "flipping"             return . reverse $ a 

Interpreting LetT

Our LetT for sharing results is at the top of our transformer stack. We'll need to interpret it to get at the computations underneath it. To interpret LetT we will need a way to share results in IO, which memoize provides, and an interpeter that removes the LetT transformer from the top of the stack.

To share computations we need to store them somewhere, this memoizes an IO computation in IO, making sure it happens only once even across multiple threads.

memoize :: (Ord k) => (k -> IO a) -> IO (k -> IO a) memoize definition = do     cache <- newMVar Map.empty     let populateCache k map = do         case Map.lookup k map of             Just a -> return (map, a)             Nothing -> do                 a <- definition k                 return (Map.insert k a map, a)             let fromCache k = do         map <- readMVar cache         case Map.lookup k map of             Just a -> return a             Nothing -> modifyMVar cache (populateCache k)     return fromCache 

In order to interpret a Let, we need an evaluator for the underlying ApT IO to incorporate into the definitions for the Let bindings. Since the result of computations depends on the environment read from the ReaderT, we will incorporate dealing with the ReaderT into this step. A more sophisticated approach would use transformer classes, but transformer classes for Applicative is a topic for a different question.

compileIP :: (forall x. ApT IO x -> IO x) ->  IP a -> IO (Int -> ApT IO a) compileIP eval (NoLet (ReaderT f)) = return (stuffAp . f) compileIP eval (Let b lf) = do             cb <- compileIP eval b             mb <- memoize (eval . cb)             compileIP eval . lf . NoLet $ ReaderT (liftAp . lift . mb) 

Interpreting ApT

Our interpreter uses the following State to avoid needing to peek inside AsT, FreeT, and FreeF all the time.

data State m a where     InPure :: a -> State m a     InAp :: State m b -> State m (b -> State m a) -> State m a     InM :: m a -> State m a  instance Functor m => Functor (State m) where     fmap f (InPure a) = InPure (f a)     fmap f (InAp b sa) = InAp b (fmap (fmap (fmap f)) sa)     fmap f (InM  m)  = InM  (fmap f m) 

Interpereting Ap is harder than it looks. The goal is to take data that's in Ap.Pure and put it in InPure and data that's in Ap and put it in InAp. interpretAp actually needs to call itself with a larger type each time it goes into a deeper Ap; the function keeps picking up another argument. The first argument t provides a way to simplify these otherwise exploding types.

interpretAp :: (Functor m) => (a -> State m b) -> Ap m a -> State m b interpretAp t (Ap.Pure a) = t a interpretAp t (Ap mb ap) = InAp sb sf     where         sb = InM mb         sf = interpretAp (InPure . (t .)) $ ap 

interperetApT gets data out of ApT, FreeT, and FreeF and into State m

interpretApT :: (Functor m, Monad m) => ApT m a -> m (State (ApT m) a) interpretApT = (fmap inAp) . runApT     where         inAp (Pure a) = InPure a         inAp (Free ap) = interpretAp (InM . ApT) $ ap 

With these simple interpreting pieces we can make strategies for interpreting results. Each strategy is a function from the interpreter's State to a new State, with possible side effect happening on the way. The order the strategy chooses to execute side effects in determines the order of the side effects. We'll make two example strategies.

The first strategy performs only one step on everything that's ready to be computed, and combines results when they are ready. This is probably the strategy that you want.

stepFB :: (Functor m, Monad m) => State (ApT m) a -> m (State (ApT m) a) stepFB (InM ma)   = interpretApT ma stepFB (InPure a) = return (InPure a) stepFB (InAp b f) = do     sf <- stepFB f     sb <- stepFB b     case (sf, sb) of         (InPure f, InPure b) -> return (f b)         otherwise            -> return (InAp sb sf) 

This other strategy performs all the calculations as soon as it knows about them. It performs them all in a single pass.

allFB :: (Functor m, Monad m) => State (ApT m) a -> m (State (ApT m) a) allFB (InM ma) = interpretApT ma allFB (InPure a) = return (InPure a) allFB (InAp b f) = do     sf <- allFB f     sb <- allFB b     case (sf, sb) of         (InPure f, InPure b) -> return (f b)         otherwise            -> allFB (InAp sb sf) 

Many, many other strategies are possible.

We can evaluate a strategy by running it until it produces a single result.

untilPure :: (Monad m) => ((State f a) -> m (State f a)) -> State f a -> m a untilPure s = go     where         go state =             case state of                 (InPure a) -> return a                 otherwise  -> s state >>= go 

Executing the intepreter

To execute the interpreter, we need some example data. Here are a few interesting examples.

example1  = (\i -> addImages [timeShift (*2) i, flipImage i]) <\> readImage 1 example1' = (\i -> addImages [timeShift (*2) i, flipImage i, flipImage . timeShift (*2) $ i]) <\> readImage 1 example1'' = (\i -> readImage 2) <\> readImage 1 example2 = addImages [timeShift (*2) . flipImage $ readImage 1, flipImage $ readImage 2] 

The LetT interpreter needs to know what evaluator to use for bound values, so we'll define our evaluator only once. A single interpretApT kicks off the evaluation by finding the initial State of the interpreter.

evaluator :: ApT IO x -> IO x evaluator = (>>= untilPure stepFB) . interpretApT 

We'll compile example2, which is essentially your example, and run it for time 5.

main = do     f <- compileIP evaluator example2     a <- evaluator . f $ 5     print a 

Which produces almost the desired result, with all reads happening before any flips.

[2] reading image for time: 5 [1] reading image for time: 10 flipping flipping "|01 :emit rof ]1[ egami||5 :emit rof ]2[ egami|"