Monadic Transducers with reduction

GettingToTesser.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveFunctor #-}

module Tesser where

import Control.Monad
import Data.Bifunctor
import Data.List (foldl')
import Data.Profunctor

--------------------------------------------------------------------------------

data FoldF m a r b
  = FoldF
    { reducer :: r -> a -> m (Either b r)
    , state   :: Either b r
    , output  :: r -> m b
    }

-- | We forget the state variable to make it more composable
data Fold m a b where Fold :: FoldF m a r b -> Fold m a b

foldlEit' :: Monad m => (r -> a -> m (Either o r)) -> m (Either o r) -> [a] -> m (Either o r)
foldlEit' f x []       = x
foldlEit' f m (a : as) = do
  e <- m
  case e of
    Left o   -> return (Left o)
    Right r0 -> foldlEit' f (f r0 a) as

outputEit :: Monad m => FoldF m a r b -> Either b r -> m b
outputEit q = either return (output q)

instance Monad m => Profunctor (Fold m) where
  dimap f g (Fold q) =
    Fold $ q { reducer = \r a -> liftM (first g) (reducer q r (f a))
             , output  = \r   -> liftM g (output q r)
             , state   = first g (state q)
             }

instance Monad m => Functor (Fold m a) where
  fmap = dimap id

fold :: Monad m => Fold m a b -> [a] -> m b
fold (Fold q) as = outputEit q =<< foldlEit' (reducer q) (return $ state q) as

--------------------------------------------------------------------------------

-- | Transducers, CPS transformed so that (f . g) performs g first and
-- then f. This means that in Clojure (->> g f) ==> (f . g) performs g
-- first and then f.
--
-- We could also achieve this by overloading (.) using a Category
-- instance, but here we (a) get to use normal, Prelude (.) and (b)
-- demonstrate that composition flipping is available whenever
-- desired.
type T m a b = forall r c . (Fold m a r -> c) -> (Fold m b r -> c)

_map :: Monad m => (a -> b) -> T m a b
_map f phi q = phi (lmap f q)

_mapCat :: Monad m => (a -> [b]) -> T m a b
_mapCat f phi (Fold q) =
  phi $ Fold $ q { reducer = \r a -> foldlEit' (reducer q) (return $ Right r) (f a) }

_keep :: Monad m => (a -> Maybe b) -> T m a b
_keep f phi (Fold q) =
  phi $ Fold $ q { reducer = \r a -> case f a of
                 Nothing -> return (Right r)
                 Just b  -> reducer q r b }

_filter :: Monad m => (a -> Bool) -> T m a a
_filter p = _keep (\a -> if p a then Just a else Nothing)

_run :: Monad m => T m a b -> ([a] -> m [b])
_run t = fold (t id buildListFold)

-- | Strict pair
data Pair a b = Pair !a !b

_take :: Monad m => Int -> T m a a
_take limit phi (Fold q) =
  phi $ Fold $ q { reducer = \(Pair remaining r) a ->
                     if remaining > 0
                     then liftM (fmap $ Pair (pred remaining)) (reducer q r a)
                     else liftM Left (output q r)
                 , state   = fmap (Pair limit) (state q)
                 , output  = \(Pair _ a) -> output q a
                 } 

buildListFold :: Monad m => Fold m a [a]
buildListFold = Fold buildListFoldF where
  -- This is the "diff list" fold
  buildListFoldF :: Monad m => FoldF m a ([a] -> [a]) [a]
  buildListFoldF =
    FoldF { reducer = \r a -> return $ Right (r . (a:))
          , state   = Right id
          , output  = \r -> return (r [])
          }