ArrowLoop instance for Control.Foldl-like datatype

Viewed 133

I am working on a modification of Control.Foldl datatype that provides instances of Category and Arrow. My definition is as follows:

data FoldlCat a b = forall x c. FoldlCat (x -> a -> c) x (c -> x) (c -> b)

where the first argument stands for a "step" function (savedState -> newInput -> intermediateValue), second is for initial savedState, third is a "save" function (intermediateValue -> savedState) and the last one is an "extract" function (intermediateValue -> newOutput).

So something like map (*10) . scanl (+) 0 can be expressed as FoldlCat (+) 0 id (*10).

The main purpose of a save function is to facilitate definitions of id and arr like so:

id = FoldlCat (\_ x -> x) () (const ()) id

Now I am unsuccessfully trying to come up with an instance of ArrowLoop. I can not see any reason for it not being possible, however, I am not comfortable enough with fix-like concepts. My best attempt so far typechecks but loops forever.

instance ArrowLoop FoldlCat where
  loop (FoldlCat s b a d) = FoldlCat step b (a . snd) fst where
    step x = loop' d (s x)
    loop' f g x = let ~(v, ~(c,d)) = let ~v = g (x,d) in (v, f v)
                  in (c, v)

I would be grateful if someone could share their approach on defining such an instance (extra kudos if it would work with a strict tuple in accumulator inside of (.)) or explain why that is not possible or advice on a better structure for FoldlCat.

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Arrows #-}

import Data.List (unfoldr)
import Prelude hiding (id, (.))
import Control.Category
import Control.Arrow

-- | FoldlCat  step init save export
data FoldlCat a b = forall x c. FoldlCat (x -> a -> c) x (c -> x) (c -> b)

mapCat :: (a -> b) -> FoldlCat a b
mapCat f = FoldlCat (\_ x -> x) () (const ()) f

evalList :: FoldlCat t b -> [t] -> [b]
evalList (FoldlCat s b a d) ys = unfoldr stepan (b, ys) where
    stepan (accVal, (x:xs))  = Just (nexVal, (newAcc, xs)) where
      newMeta = s accVal x
      newAcc  = a newMeta
      nexVal  = d newMeta
    stepan (accVal, [])      = Nothing

delay :: b -> FoldlCat b b
delay def = FoldlCat (,) def snd fst

instance Category FoldlCat where
  id = mapCat id

  (.) (FoldlCat step2 begin2 acc2 done2) (FoldlCat step1 begin1 acc1 done1) =
      let step = \(a, b) y -> let !a' = step1 a y
                                  !b' = step2 b (done1 a') in (a', b')
          begin = (begin1, begin2)
          acc   = \(x, y) -> ((acc1 x), (acc2 y))
          done = \(a, b) -> done2 b
      in
        FoldlCat step begin acc done

instance Arrow FoldlCat where
  arr f = mapCat f

  first (FoldlCat s b a d) = FoldlCat step b (a . fst) extF where
    step = (\a (x, y) -> (s a x, y))
    extF = (\(ok, y) -> (d ok, y))

instance ArrowLoop FoldlCat where
  loop (FoldlCat s b a d) = FoldlCat step b (a . snd) fst where
    step x = loop' d (s x)
    loop' f g x = let ~(v, ~(c,d)) = let ~v = g (x,d) in (v, f v)
                  in (c, v)

chaseFromZero = proc target -> do
  rec let step = signum (target - x)
      x <- FoldlCat (+) 0 id id <<< delay 0 -< step
  id -< x

main = print $ evalList chaseFromZero [1..5]

EDIT Although I am not sure how and why it works, fixing strictness of step in (.) (i.e. removing bang in let !a' = step1 a y) seems to make this example work.

0 Answers
Related