Not yet Tesser, but getting there

Tesser.hs

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

module Tesser where

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

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

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

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


foldlEit' :: (r -> a -> Either o r) -> Either o r -> [a] -> Either o r
foldlEit' f x []       = x
foldlEit' f (Left o) _ = Left o
foldlEit' f (Right r0) (a : as) =
  let r1 = f r0 a
  in r1 `seq` foldlEit' f r1 as

outputEit :: FoldF a r b -> Either b r -> b
outputEit q = either id (output q)

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

instance Functor (Fold a) where
  fmap = dimap id

fold :: Fold a b -> [a] -> b
fold (Fold q) as = outputEit q (foldlEit' (reducer q) (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 a ~> b = forall r c . (Fold a r -> c) -> (Fold b r -> c)

_map :: (a -> b) -> (a ~> b)
_map f phi q = phi (lmap f q)

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

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

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

_run :: (a ~> b) -> ([a] -> [b])
_run t = fold (t id buildListFold)

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

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

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


-- λ> _run (_map (*2) . _filter (> 1)) [1,2,3,4]
-- [4,6,8]
--
-- λ> _run (_filter (> 1) . _map (*2)) [1,2,3,4]
-- [2,4,6,8]
--
-- λ> _run (_take 3) [1..10]
-- [1,2,3]
--
-- λ> _run (_take 3) [1..]
-- [1,2,3]

What's the first function you're using here?

The first function?

Data.Bifunctor (first)

Oh, ha, yes! It's fmap over the left side of an Either.