From ce0510c37251d0bc0f6bdb4b09d589d55bf8e6fe Mon Sep 17 00:00:00 2001
From: Marcin Szamotulski <profunctor@pm.me>
Date: Sun, 6 Oct 2019 23:16:40 +0100
Subject: [PATCH] Added foldrL, foldrL and zipWithL

This matches the api of Queue.
---
 ChangeLog.md                          |  2 ++
 src/Control/Category/Free.hs          |  4 +++
 src/Control/Category/Free/Internal.hs | 39 +++++++++++++++++++++++++++
 3 files changed, 45 insertions(+)

diff --git a/ChangeLog.md b/ChangeLog.md
index 321909c..a580e9e 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -26,3 +26,5 @@
     - `liftCat` to `liftEffect`
     - `foldNatLift` to `foldNatEffCat`
 - Show instance of 'Cat' and 'C' via 'ListTr' (GHC >= 806)
+- Export ListTr from Control.Category.Free
+- foldrL, foldlL and zipWithL
diff --git a/src/Control/Category/Free.hs b/src/Control/Category/Free.hs
index ce0352c..672999a 100644
--- a/src/Control/Category/Free.hs
+++ b/src/Control/Category/Free.hs
@@ -35,11 +35,15 @@ module Control.Category.Free
     , foldNatQ
     , foldrQ
     , foldlQ
+    , zipWithQ
 
       -- * Type alligned list
     , ListTr (..)
     , liftL
     , foldNatL
+    , foldlL
+    , foldrL
+    , zipWithL
 
       -- * Free Category based on Queue
     , Cat (Id)
diff --git a/src/Control/Category/Free/Internal.hs b/src/Control/Category/Free/Internal.hs
index 38ab017..93b4a69 100644
--- a/src/Control/Category/Free/Internal.hs
+++ b/src/Control/Category/Free/Internal.hs
@@ -33,6 +33,9 @@ module Control.Category.Free.Internal
   , liftL
   , foldNatL
   , lengthListTr
+  , foldrL
+  , foldlL
+  , zipWithL
   , Queue (NilQ, ConsQ)
   , liftQ
   , nilQ
@@ -165,6 +168,42 @@ foldNatL fun (ConsTr bc ab) = fun bc . foldNatFree2 fun ab
 
 #-}
 
+-- | 'foldr' of a 'ListTr'
+--
+foldrL :: forall (f :: k -> k -> *) c a b d.
+          (forall x y z. f y z -> c x y -> c x z)
+       -> c a b
+       -> ListTr f b d
+       -> c a d
+foldrL _nat ab NilTr          = ab
+foldrL  nat ab (ConsTr xd bx) = nat xd (foldrL nat ab bx)
+{-# INLINE [1] foldrL #-}
+
+-- | 'foldl' of a 'ListTr'
+--
+-- TODO: make it strict, like 'foldl''.
+--
+foldlL :: forall (f :: k -> k -> *) c a b d.
+          (forall x y z. c y z -> f x y -> c x z)
+       -> c b d
+       -> ListTr f a b
+       -> c a d
+foldlL _nat bd NilTr          = bd
+foldlL  nat bd (ConsTr xb ax) = foldlL nat (nat bd xb) ax
+
+zipWithL :: forall f g a b a' b'.
+        Category f
+     => (forall x y x' y'. f x y -> f x' y' -> f (g x x') (g y y'))
+     -> ListTr f a  b
+     -> ListTr f a' b'
+     -> ListTr f (g a a') (g b b')
+zipWithL fn queueA queueB = case (queueA, queueB) of
+    (NilTr, NilTr) -> NilTr
+    (NilTr, ConsTr trB' queueB') -> ConsTr (id   `fn` trB') (zipWithL fn NilTr    queueB')
+    (ConsTr trA' queueA', NilTr) -> ConsTr (trA' `fn` id)   (zipWithL fn queueA' NilTr)
+    (ConsTr trA' queueA', ConsTr trB' queueB')
+                                 -> ConsTr (trA' `fn` trB') (zipWithL fn queueA' queueB')
+
 #if __GLASGOW_HASKELL__ >= 806
 instance (forall (x :: k) (y :: k). Show (f x y)) => Show (ListTr f a b) where
     show NilTr         = "NilTr"