1monad2interpreters - Intertwined by one effect: `listen`

Main.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

import Control.Monad
import Control.Monad.Free

import System.Random



main = do
  putStrLn "TEST t - generate a couple random numbers and `say` them:"
  res <- runIO t
  print res

  putStrLn "TEST t1 - run 2 instances of t `listen`-ing what they `say`:"
  res <- runIO t1
  print res

  putStrLn "TEST t2 - `say` (a+b)*(c+d) N times, `listen`-ing the results"
  putStrLn "          format: [ iter, a, b, c, d, (a+b)*(c+d), repeat.. ]"
  res <- runIO t2
  print res

  putStrLn "TEST t3 - show multiple subsequent `listen`s (don't interfere)"
  res <- runIO t3
  print res

  putStrLn "TEST t4 - listen inside a listen"
  res <- runIO t4
  print res



-- Free Monad

data F s where
  Say :: Show a => s -> a -> F s
  Rand :: (Int -> s) -> F s
  Listen :: (([String],a) -> s) -> E a -> F s

deriving instance (Functor F)

type E = Free F



-- Actions

say :: Show a => a -> E ()
say = liftF . Say ()

rand :: E Int
rand = liftF $ Rand id

listen :: E a -> E ([String], a)
listen = liftF . Listen id

listen_ :: E a -> E [String]
listen_ = fmap fst . listen



-- Test: generate some random numbers, say them

t = do
  n <- rand
  say n
  m <- rand
  say m
  return $ n+m

-- Test: listen the says from an action!

t1 = do
  n <- rand            -- random num
  say n                -- say it
  log <- listen $ do  -- \
    a <- t             --  \ do t twice and return a number
    b <- t             --  / this will produce 4 `Say`s total
    return $ a*b       -- /
  say log              -- say the log
  say $ length log * n -- say n times the length of the log

-- Test: a convoluted way to calculate (a random number of) products of sums

t2 = do
  n <- rand
  say n
  log <- listen_ $ do
    forM_ [1 .. n] $ \i -> do
      say i
      a <- t
      b <- t
      say $ a*b
  say log

-- Test: show multiple `listen`s

t3 = do
  n <- rand
  say n
  l1 <- listen_ $ do
    forM_ [1 .. n] $ \i -> do
      n <- rand
      m <- rand
      say n
      say m
      say (n, m, n+m)
  say l1
  n <- rand
  say n
  l2 <- listen_ $ do
    forM_ [1 .. n] $ \i -> do
      n <- rand
      m <- rand
      say n
      say m
      say (n, m, n*m)
  say l2

-- Test: embedded `listen`s

t4 = do
  n <- rand
  say n
  log <- listen_ $ forM_ [1 .. n] $ \i -> do
    m <- rand
    say m
    log' <- listen_ $ do
      nums <- forM [1 .. m] $ \j -> do
        a <- rand
        say $ (i,j,a)
        return a
      say nums
    say $ m + 1 == length log'  -- since it logs m numbers and then their list
  say log



-- Main interpreter

runIO :: E a -> IO a

runIO (Pure n) = return n

runIO (Free (Say next x)) = do
  print x
  runIO next

runIO (Free (Rand next)) = do
  n <- randomRIO (1,5)
  runIO (next n)

runIO (Free (Listen next actions)) = do
  res <- runL actions  -- dynamically switch to the listening interpreter
  runIO (next res)



-- Listening interpreter

runL :: E a -> IO ([String], a)

runL (Pure x) = return ([], x)

runL (Free (Say next x)) = do
  (log, y) <- runL next
  return (show x : log, y)

runL (Free (Rand next)) = runIO rand >>= runL . next

runL (Free (Listen next actions)) = do
  (log1, x1) <- runIO (listen actions)
  (log2, x2) <- runL $ next (log1, x1)
  return (log1 ++ log2, x2)