fold, foldMap, foldl, & foldr

Data/TASequence.hs

@@ -104,7 +104,29 @@ class TASequence (s :: (k -> k -> *) -> k -> k -> *) where
   -- >    TAEmptyL -> tempty
   -- >    h :< t -> f h <| tmap f t
   tmap       :: (forall x y. c x y -> d x y) -> s c x y -> s d x y
-
+
+  -- | Apply a function to all elements in a type aligned sequence, and combine them using a 'Category' instance.
+  --
+  -- Default definition:
+  --
+  -- > tfoldMap f q = case tviewl q of
+  -- >   TAEmptyL -> id
+  -- >   h :< t -> f h >>> tfoldMap f t
+  tfoldMap   :: Category d => (forall x y. c x y -> d x y) -> s c x y -> d x y
+
+  -- | Combine all elements in a type aligned sequence using a 'Category' instance.
+  --
+  -- Default definition:
+  --
+  -- > tfold = tfoldMap id
+  tfold      :: Category c => s c x y -> c x y
+
+  -- | Right-associative fold of a type aligned sequence.
+  tfoldr     :: (forall x y z . c x y -> d y z -> d x z) -> d q r -> s c p q -> d p r
+
+  -- | Left-associative fold of a type aligned sequence.
+  tfoldl     :: (forall x y z . d x y -> c y z -> d x z) -> d p q -> s c q r -> d p r
+
   l |> r = l >< tsingleton r
   l <| r = tsingleton l >< r
   l >< r = case tviewl l of
@@ -127,6 +149,15 @@ class TASequence (s :: (k -> k -> *) -> k -> k -> *) where
     TAEmptyL -> tempty
     h :< t -> f h <| tmap f t
 
+  tfoldMap f q = case tviewl q of
+    TAEmptyL -> id
+    h :< t -> f h >>> tfoldMap f t
+
+  tfold = tfoldMap id
+
+  tfoldr f z t = appEndoR (tfoldMap (\ x -> EndoR (\ y -> f x y)) t) z
+
+  tfoldl f z t = appEndoL (tfoldMap (\ x -> EndoL (\ y -> f y x)) t) z
 
 data TAViewL s c x y where
    TAEmptyL  :: TAViewL s c x x
@@ -135,3 +166,17 @@ data TAViewL s c x y where
 data TAViewR s c x y where
    TAEmptyR  :: TAViewR s c x x
    (:>)     :: s c x y -> c y z -> TAViewR s c x z
+
+
+-- Approach adapted from Joachim Breitner: https://stackoverflow.com/a/30986119/88018
+newtype EndoR h c d = EndoR { appEndoR :: forall b. h d b -> h c b  }
+
+instance Category (EndoR h) where
+  id = EndoR id
+  EndoR f1 . EndoR f2 = EndoR (f2 . f1)
+
+newtype EndoL h c d = EndoL { appEndoL :: forall b . h b c -> h b d }
+
+instance Category (EndoL h) where
+  id = EndoL id
+  EndoL f1 . EndoL f2 = EndoL (f1 . f2)

Data/TASequence/BinaryTree.hs

@@ -19,6 +19,7 @@ module Data.TASequence.BinaryTree(module Data.TASequence, BinaryTree) where
 
 import  Control.Category
 import  Data.TASequence
+import  Prelude hiding (id)
 
 data BinaryTree c x y where
   Empty :: BinaryTree c x x
@@ -39,6 +40,10 @@ instance TASequence BinaryTree where
   tmap phi (Leaf c) = Leaf (phi c)
   tmap phi (Node b b') = Node (tmap phi b) (tmap phi b')
 
+  tfoldMap phi Empty      = id
+  tfoldMap phi (Leaf c)   = phi c
+  tfoldMap phi (Node a b) = tfoldMap phi a >>> tfoldMap phi b
+
 instance Category (BinaryTree c) where
   id = tempty
   (.) = flip (><)

Data/TASequence/FingerTree.hs

@@ -24,6 +24,7 @@ module Data.TASequence.FingerTree (module Data.TASequence, FingerTree ) where
 
 import Control.Category
 import Data.TASequence
+import Prelude hiding (id)
 
 
 data FingerTree r a b where
@@ -71,6 +72,10 @@ instance TASequence FingerTree where
   tmap f (Single a) = Single (f a)
   tmap f (Deep l m r) = Deep (mapd f l) (tmap (mapn f) m) (mapd f r)
 
+  tfoldMap f Empty = id
+  tfoldMap f (Single a) = f a
+  tfoldMap f (Deep l m r) = foldMapd f l >>> tfoldMap (foldMapn f) m >>> foldMapd f r
+
 instance Category (FingerTree c) where
   id = tempty
   (.) = flip (><)
@@ -194,11 +199,19 @@ nodes (a ::: b ::: c ::: xs) = Node3 a b c ::: nodes xs
 mapn :: (forall x y. c x y -> d x y) -> Node c x y -> Node d x y
 mapn phi (Node2 r s) = Node2 (phi r) (phi s)
 mapn phi (Node3 r s t) = Node3 (phi r) (phi s) (phi t)
-
+
+foldMapn :: Category d => (forall x y. c x y -> d x y) -> Node c x y -> d x y
+foldMapn phi (Node2 r s) = phi r >>> phi s
+foldMapn phi (Node3 r s t) = phi r >>> phi s >>> phi t
+
 mapd :: (forall x y. c x y -> d x y) -> Digit c x y -> Digit d x y
 mapd phi (One r) = One (phi r) 
 mapd phi (Two r s) = Two (phi r) (phi s)
 mapd phi (Three r s t) = Three (phi r) (phi s) (phi t)
 mapd phi (Four r s t u) = Four (phi r) (phi s) (phi t) (phi u)
 
-
+foldMapd :: Category d => (forall x y. c x y -> d x y) -> Digit c x y -> d x y
+foldMapd phi (One r) = phi r
+foldMapd phi (Two r s) = phi r >>> phi s
+foldMapd phi (Three r s t) = phi r >>> phi s >>> phi t
+foldMapd phi (Four r s t u) = phi r >>> phi s >>> phi t >>> phi u

Data/TASequence/Queue.hs

@@ -23,6 +23,7 @@ module Data.TASequence.Queue(module Data.TASequence,Queue)  where
 
 import Control.Category
 import Data.TASequence
+import Prelude hiding (id)
 
 data P c a b where
   (:*) :: c a w -> c w b -> P c a b
@@ -60,13 +61,24 @@ instance TASequence Queue where
   tmap f (Q1 x) = Q1 (f x)
   tmap f (QN l m r) = QN (tmapb f l) (tmap (tmapp f) m) (tmapb f r)
 
+  tfoldMap f Q0 = id
+  tfoldMap f (Q1 x) = f x
+  tfoldMap f (QN l m r) = tfoldMapb f l >>> tfoldMap (tfoldMapp f) m >>> tfoldMapb f r
+
 instance Category (Queue c) where
   id = tempty
   (.) = flip (><)
 
 tmapp :: (forall x y. c x y -> d x y) -> P c x y -> P d x y
 tmapp phi (a :* b) = phi a :* phi b
-
+
+tfoldMapp :: Category d => (forall x y. c x y -> d x y) -> P c x y -> d x y
+tfoldMapp phi (a :* b) = phi a >>> phi b
+
 tmapb :: (forall x y. c x y -> d x y) -> B c x y -> B d x y
 tmapb phi (B1 c) = B1 (phi c)
 tmapb phi (B2 p) = B2 (tmapp phi p)
+
+tfoldMapb :: Category d => (forall x y. c x y -> d x y) -> B c x y -> d x y
+tfoldMapb phi (B1 c) = phi c
+tfoldMapb phi (B2 p) = tfoldMapp phi p

Data/TASequence/SnocList.hs

@@ -18,6 +18,7 @@ module Data.TASequence.SnocList(module Data.TASequence,SnocList(..))  where
 
 import Control.Category
 import Data.TASequence
+import Prelude hiding (id)
 
 data SnocList c x y where
   SNil :: SnocList c x x
@@ -32,6 +33,9 @@ instance TASequence SnocList where
   tmap phi SNil = SNil
   tmap phi (Snoc s c) = Snoc (tmap phi s) (phi c)
 
+  tfoldMap phi SNil = id
+  tfoldMap phi (Snoc s c) = tfoldMap phi s >>> phi c
+
 instance Category (SnocList c) where
   id = tempty
   (.) = flip (><)

Data/TASequence/ToCatQueue.hs

@@ -24,6 +24,7 @@ module Data.TASequence.ToCatQueue(module Data.TASequence,ToCatQueue) where
 
 import Control.Category
 import Data.TASequence
+import Prelude hiding (id)
 
 -- | The catenable queue type. The first type argument is the 
 -- type of the queue we use (|>)
@@ -51,6 +52,9 @@ instance TASequence q => TASequence (ToCatQueue q) where
  tmap phi C0 = C0
  tmap phi (CN c q) = CN (phi c) (tmap (tmap phi) q)
 
+ tfoldMap phi C0 = id
+ tfoldMap phi (CN c q) = phi c >>> tfoldMap (tfoldMap phi) q
+
 instance TASequence q => Category (ToCatQueue q c) where
   id = tempty
   (.) = flip (><)