Tesseralike, but not there yet

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 x s b
  = FoldF
    { reducer0 :: r -> a -> Either x r
    , state0   :: Either x r
    , output0  :: r -> x
    , reducer1 :: s -> x -> Either b s
    , state1   :: Either b s
    , output1  :: s -> b
    }

-- | We forget the state variable to make it more composable
data Fold a b where Fold :: FoldF a r x s 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

instance Profunctor Fold where
  dimap f g (Fold q) =
    Fold $ q { reducer0 = \r a -> reducer0 q r (f a)
             , reducer1 = \s x -> first g (reducer1 q s x)
             , output1  = \s   -> g (output1 q s)
             , state1   =         first g (state1 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 { reducer0 = \r a -> foldlEit' (reducer0 q) (Right r) (f a) }

_keep :: (a -> Maybe b) -> (a ~> b)
_keep f phi (Fold q) =
  phi $ Fold $ q { reducer0 = \r a -> case f a of
                       Nothing -> Right r
                       Just b  -> reducer0 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] -> [a]) ([a] -> [a]) [a]
  buildListFoldF =
    FoldF { reducer0 = \r a -> Right (r . (a:))
          , state0   = Right id
          , output0  = id
          , reducer1 = \s x -> Right (s . x)
          , state1   = Right id
          , output1  = \s -> s []
          }