example.purs

test = map ((*) 2) >>> filter ((>) 15) >>> drop 3 >>> map show
src1 = [10, 9, 8, 7, 6, 5, 4, 3, 2, 1]
src2 = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]

res1 = transduce' test src1 :: [String]
res2 = transduce' test src2 :: List String

purescript-transducers.purs

module Control.Transducer
  ( Fold()
  , mkFold
  , runFold
  , fold
  , Transducer()
  , mkTrans
  , runTrans
  , map
  , filter
  , takeWhile
  , dropWhile
  , take
  , drop
  , transduce
  , transduce'
  , Into
  , Reducable
  , into
  , reduce
  , sink
  ) where

import Data.Exists
import Data.Tuple
import Data.Monoid
import Data.Maybe
import Data.Either
import Data.Function
import Data.Array (snoc)
import qualified Data.List as L
import qualified Data.Foldable as F

data Moore a b r = Moore (r -> a -> Either r r) r (r -> b)

newtype Fold a b = Fold (Exists (Moore a b))

mkFold :: forall a b r. (r -> a -> Either r r) -> r -> (r -> b) -> Fold a b
mkFold step init stop = Fold (mkExists (Moore step init stop))

mkFold' :: forall a b r. (r -> a -> r) -> r -> (r -> b) -> Fold a b
mkFold' step = mkFold (\r x -> Right (step r x))

runFold :: forall a b o. Fold a b -> (forall r. (r -> a -> Either r r) -> r -> (r -> b) -> o) -> o
runFold (Fold f) g = runExists (\(Moore s i e) -> g s i e) f

fold :: forall f a b. (F.Foldable f) => (Fold a b) -> f a -> b
fold f xs = runFold f \step init stop ->
  let step' l@(Left _) _ = l
      step' (Right r)  x = step r x
  in  either stop stop $ F.foldl step' (Right init) xs

instance functorFold :: Functor (Fold a) where
  (<$>) f fold = runFold fold \s i e -> mkFold s i (f <<< e)

newtype Transducer a b = Trans (forall o. Fold b o -> Fold a o)

mkTrans :: forall a b. (forall r o. (r -> b -> Either r r) -> r -> (r -> o) -> Fold a o) -> Transducer a b
mkTrans t = Trans \f -> runFold f t

runTrans :: forall a b o. Transducer a b -> Fold b o -> Fold a o
runTrans (Trans t) = t

instance semigroupoidTransducer :: Semigroupoid Transducer where
  (<<<) (Trans f) (Trans g) = Trans (g <<< f) -- fix composition order

instance functorTransducer :: Functor (Transducer a) where
  (<$>) f t = t >>> map f

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

map :: forall a b. (a -> b) -> Transducer a b
map f = mkTrans \step -> mkFold \r x -> step r (f x)

filter :: forall a. (a -> Boolean) -> Transducer a a
filter p = mkTrans \step -> mkFold \r x -> if p x then step r x else Right r

takeWhile :: forall a. (a -> Boolean) -> Transducer a a
takeWhile p = mkTrans \step -> mkFold \r x -> if p x then step r x else Left r

dropWhile :: forall a. (a -> Boolean) -> Transducer a a
dropWhile p = mkTrans \step -> mkFold \r x -> if p x then Right r else step r x

take :: forall a. Number -> Transducer a a
take n = mkTrans \step' init' stop' ->
  let init = Tuple n init'
      stop = stop' <<< snd

      step r@(Tuple 0 _) _ = Left r
      step (Tuple n r')  x = either (Left <<< Tuple n) (Right <<< Tuple (n - 1)) (step' r' x)

  in  mkFold step init stop

drop :: forall a. Number -> Transducer a a
drop n = mkTrans \step' init' stop' ->
  let init = Tuple n init'
      stop = stop' <<< snd

      step (Tuple 0 r) x = either (Left <<< Tuple 0) (Right <<< Tuple 0) (step' r x)
      step (Tuple n r) _ = Right (Tuple (n - 1) r)

  in  mkFold step init stop

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

class Reducable f where
  reduce :: forall a b r. f a -> (r -> a -> Either r r) -> r -> (r -> b) -> b

class Into f where
  into :: forall a. f a -> Fold a (f a)

sink :: forall f a. (Into f, Monoid (f a)) => Fold a (f a)
sink = into mempty

transduce :: forall f g a b. (Reducable f, Into g) => Transducer a b -> Fold b (g b) -> f a -> g b
transduce t s = runFold (runTrans t s) <<< reduce

transduce' :: forall f g a b. (Reducable f, Into g, Monoid (g b)) => Transducer a b -> f a -> g b
transduce' t = transduce t sink

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

unwrapEither :: forall a. Either a a -> a
unwrapEither (Left x) = x
unwrapEither (Right x) = x

instance reducableArray :: Reducable Prim.Array where
  reduce xs step init stop = runFn6 reduceArrayImpl isLeft unwrapEither step init stop xs

instance intoArray :: Into Prim.Array where
  into xs = mkFold step xs id where
    step r x = Right (r `snoc` x)

foreign import reduceArrayImpl
  """
  function reduceArrayImpl(isLeft, unwrap, step, init, stop, xs) {
    var state = init;
    var either;
    for (var i = 0; i < xs.length; i++) {
      either = step(state)(xs[i]);
      state  = unwrap(either);
      if (isLeft(either)) break;
    }
    return stop(state);
  }
  """ :: forall a b r. Fn6 (forall a b. Either a b -> Boolean)
                           (forall a. Either a a -> a)
                           (r -> a -> Either r r) r (r -> b) [a] b

instance reducableList :: Reducable L.List where
  reduce xs step init stop = go xs init where
    go L.Nil         r = stop r
    go (L.Cons x xs) r = either stop (go xs) (step r x)

instance intoList :: Into L.List where
  into init = mkFold step L.Nil ((<>) init <<< L.reverse) where
    step r x = Right (L.Cons x r)