From 9a0a4e7dd40d7f3a2c6c7874d226f7c8a8298c27 Mon Sep 17 00:00:00 2001 From: Alex Denko Date: Sat, 28 Feb 2026 16:27:16 -0600 Subject: [PATCH 1/4] add ZipCofree wrapper type with zipping Apply and Applicative instances. --- src/Control/Comonad/ZipCofree.purs | 53 ++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) create mode 100644 src/Control/Comonad/ZipCofree.purs diff --git a/src/Control/Comonad/ZipCofree.purs b/src/Control/Comonad/ZipCofree.purs new file mode 100644 index 0000000..4120bec --- /dev/null +++ b/src/Control/Comonad/ZipCofree.purs @@ -0,0 +1,53 @@ +module Control.Comonad.ZipCofree where + +import Control.Applicative (pure) +import Control.Apply (class Apply, lift2) +import Control.Comonad (class Comonad) +import Control.Comonad.Cofree (Cofree, deferCofree, head, tail) +import Control.Extend (class Extend) +import Control.Lazy as Z +import Data.Eq (class Eq, class Eq1) +import Data.Foldable (class Foldable) +import Data.FoldableWithIndex (class FoldableWithIndex) +import Data.FunctorWithIndex (class FunctorWithIndex) +import Data.Monoid (class Monoid, class Semigroup) +import Data.Newtype (class Newtype) +import Data.Ord (class Ord, class Ord1) +import Data.Traversable (class Traversable) +import Data.TraversableWithIndex (class TraversableWithIndex) +import Data.Tuple (Tuple(..)) +import Prelude (class Applicative, class Functor) +import Safe.Coerce (coerce) + +-- | `ZipCofree` is a newtype around `Cofree` which provides a zippy +-- | `Apply` instance. +newtype ZipCofree f a = ZipCofree (Cofree f a) +derive instance newtypeZipCofree :: Newtype (ZipCofree f a) _ + +derive newtype instance semigroupZipCofree :: (Apply f, Semigroup a) => Semigroup (ZipCofree f a) +derive newtype instance monoidZipCofree :: (Applicative f, Monoid a) => Monoid (ZipCofree f a) +derive newtype instance ordZipCofree :: (Ord1 f, Ord a) => Ord (ZipCofree f a) +derive newtype instance ord1ZipCofree :: (Ord1 f) => Ord1 (ZipCofree f) +derive newtype instance eqZipCofree :: (Eq1 f, Eq a) => Eq (ZipCofree f a) +derive newtype instance eq1ZipCofree :: (Eq1 f) => Eq1 (ZipCofree f) +derive newtype instance functorZipCofree :: Functor f => Functor (ZipCofree f) +derive newtype instance functorWithIndexZipCofree :: FunctorWithIndex Int f => FunctorWithIndex Int (ZipCofree f) +derive newtype instance extendZipCofree :: Functor f => Extend (ZipCofree f) +derive newtype instance comonadZipCofree :: Functor f => Comonad (ZipCofree f) +derive newtype instance foldableZipCofree :: Foldable f => Foldable (ZipCofree f) +derive newtype instance foldableWithIndexZipCofree :: FoldableWithIndex Int f => FoldableWithIndex Int (ZipCofree f) +derive newtype instance traversableZipCofree :: Traversable f => Traversable (ZipCofree f) +derive newtype instance traversableWithIndexZipCofree :: TraversableWithIndex Int f => TraversableWithIndex Int (ZipCofree f) +derive newtype instance lazyZipCofree :: Z.Lazy (ZipCofree f a) + +instance applyZipCofree :: Apply f => Apply (ZipCofree f) where + apply :: forall a b. ZipCofree f (a -> b) -> ZipCofree f a -> ZipCofree f b + apply = coerce go where + go :: Cofree f (a -> b) -> Cofree f a -> Cofree f b + go ff aa = deferCofree \_ -> Tuple (head ff (head aa)) (lift2 go (tail ff) (tail aa)) + +instance applicativeZipCofree :: Applicative f => Applicative (ZipCofree f) where + pure :: forall a. a -> ZipCofree f a + pure = coerce go where + go :: a -> Cofree f a + go a = let node = deferCofree \_ -> Tuple a (pure node) in node \ No newline at end of file From 6fe4a7b4493891e4cc76ce889fbbbffa00c14895 Mon Sep 17 00:00:00 2001 From: Alex Denko Date: Sat, 28 Feb 2026 16:49:03 -0600 Subject: [PATCH 2/4] Lint and fix overly restrictive indexed typeclass constraints --- src/Control/Comonad/ZipCofree.purs | 112 +++++++++++++++-------------- 1 file changed, 59 insertions(+), 53 deletions(-) diff --git a/src/Control/Comonad/ZipCofree.purs b/src/Control/Comonad/ZipCofree.purs index 4120bec..2834741 100644 --- a/src/Control/Comonad/ZipCofree.purs +++ b/src/Control/Comonad/ZipCofree.purs @@ -1,53 +1,59 @@ -module Control.Comonad.ZipCofree where - -import Control.Applicative (pure) -import Control.Apply (class Apply, lift2) -import Control.Comonad (class Comonad) -import Control.Comonad.Cofree (Cofree, deferCofree, head, tail) -import Control.Extend (class Extend) -import Control.Lazy as Z -import Data.Eq (class Eq, class Eq1) -import Data.Foldable (class Foldable) -import Data.FoldableWithIndex (class FoldableWithIndex) -import Data.FunctorWithIndex (class FunctorWithIndex) -import Data.Monoid (class Monoid, class Semigroup) -import Data.Newtype (class Newtype) -import Data.Ord (class Ord, class Ord1) -import Data.Traversable (class Traversable) -import Data.TraversableWithIndex (class TraversableWithIndex) -import Data.Tuple (Tuple(..)) -import Prelude (class Applicative, class Functor) -import Safe.Coerce (coerce) - --- | `ZipCofree` is a newtype around `Cofree` which provides a zippy --- | `Apply` instance. -newtype ZipCofree f a = ZipCofree (Cofree f a) -derive instance newtypeZipCofree :: Newtype (ZipCofree f a) _ - -derive newtype instance semigroupZipCofree :: (Apply f, Semigroup a) => Semigroup (ZipCofree f a) -derive newtype instance monoidZipCofree :: (Applicative f, Monoid a) => Monoid (ZipCofree f a) -derive newtype instance ordZipCofree :: (Ord1 f, Ord a) => Ord (ZipCofree f a) -derive newtype instance ord1ZipCofree :: (Ord1 f) => Ord1 (ZipCofree f) -derive newtype instance eqZipCofree :: (Eq1 f, Eq a) => Eq (ZipCofree f a) -derive newtype instance eq1ZipCofree :: (Eq1 f) => Eq1 (ZipCofree f) -derive newtype instance functorZipCofree :: Functor f => Functor (ZipCofree f) -derive newtype instance functorWithIndexZipCofree :: FunctorWithIndex Int f => FunctorWithIndex Int (ZipCofree f) -derive newtype instance extendZipCofree :: Functor f => Extend (ZipCofree f) -derive newtype instance comonadZipCofree :: Functor f => Comonad (ZipCofree f) -derive newtype instance foldableZipCofree :: Foldable f => Foldable (ZipCofree f) -derive newtype instance foldableWithIndexZipCofree :: FoldableWithIndex Int f => FoldableWithIndex Int (ZipCofree f) -derive newtype instance traversableZipCofree :: Traversable f => Traversable (ZipCofree f) -derive newtype instance traversableWithIndexZipCofree :: TraversableWithIndex Int f => TraversableWithIndex Int (ZipCofree f) -derive newtype instance lazyZipCofree :: Z.Lazy (ZipCofree f a) - -instance applyZipCofree :: Apply f => Apply (ZipCofree f) where - apply :: forall a b. ZipCofree f (a -> b) -> ZipCofree f a -> ZipCofree f b - apply = coerce go where - go :: Cofree f (a -> b) -> Cofree f a -> Cofree f b - go ff aa = deferCofree \_ -> Tuple (head ff (head aa)) (lift2 go (tail ff) (tail aa)) - -instance applicativeZipCofree :: Applicative f => Applicative (ZipCofree f) where - pure :: forall a. a -> ZipCofree f a - pure = coerce go where - go :: a -> Cofree f a - go a = let node = deferCofree \_ -> Tuple a (pure node) in node \ No newline at end of file +module Control.Comonad.ZipCofree + ( ZipCofree(..) + ) where + +import Control.Applicative (pure) +import Control.Apply (class Apply, lift2) +import Control.Comonad (class Comonad) +import Control.Comonad.Cofree (Cofree, deferCofree, head, tail) +import Control.Extend (class Extend) +import Control.Lazy as Z +import Data.Eq (class Eq, class Eq1) +import Data.Foldable (class Foldable) +import Data.FoldableWithIndex (class FoldableWithIndex) +import Data.FunctorWithIndex (class FunctorWithIndex) +import Data.Monoid (class Monoid) +import Data.Newtype (class Newtype) +import Data.Ord (class Ord, class Ord1) +import Data.Semigroup (class Semigroup) +import Data.Traversable (class Traversable) +import Data.TraversableWithIndex (class TraversableWithIndex) +import Data.Tuple (Tuple(..)) +import Prelude (class Applicative, class Functor, ($)) +import Safe.Coerce (coerce) + +-- | `ZipCofree` is a newtype around `Cofree` which provides a zippy +-- | `Apply` instance. +newtype ZipCofree f a = ZipCofree (Cofree f a) + +derive instance newtypeZipCofree :: Newtype (ZipCofree f a) _ + +derive newtype instance semigroupZipCofree :: (Apply f, Semigroup a) => Semigroup (ZipCofree f a) +derive newtype instance monoidZipCofree :: (Applicative f, Monoid a) => Monoid (ZipCofree f a) +derive newtype instance ordZipCofree :: (Ord1 f, Ord a) => Ord (ZipCofree f a) +derive newtype instance ord1ZipCofree :: (Ord1 f) => Ord1 (ZipCofree f) +derive newtype instance eqZipCofree :: (Eq1 f, Eq a) => Eq (ZipCofree f a) +derive newtype instance eq1ZipCofree :: (Eq1 f) => Eq1 (ZipCofree f) +derive newtype instance functorZipCofree :: Functor f => Functor (ZipCofree f) +derive newtype instance functorWithIndexZipCofree :: Functor f => FunctorWithIndex Int (ZipCofree f) +derive newtype instance extendZipCofree :: Functor f => Extend (ZipCofree f) +derive newtype instance comonadZipCofree :: Functor f => Comonad (ZipCofree f) +derive newtype instance foldableZipCofree :: Foldable f => Foldable (ZipCofree f) +derive newtype instance foldableWithIndexZipCofree :: Foldable f => FoldableWithIndex Int (ZipCofree f) +derive newtype instance traversableZipCofree :: Traversable f => Traversable (ZipCofree f) +derive newtype instance traversableWithIndexZipCofree :: Traversable f => TraversableWithIndex Int (ZipCofree f) +derive newtype instance lazyZipCofree :: Z.Lazy (ZipCofree f a) + +instance applyZipCofree :: Apply f => Apply (ZipCofree f) where + apply :: forall a b. ZipCofree f (a -> b) -> ZipCofree f a -> ZipCofree f b + apply = coerce go + where + go :: Cofree f (a -> b) -> Cofree f a -> Cofree f b + go ff aa = deferCofree \_ -> Tuple (head ff $ head aa) (lift2 go (tail ff) (tail aa)) + +instance applicativeZipCofree :: Applicative f => Applicative (ZipCofree f) where + pure :: forall a. a -> ZipCofree f a + pure = coerce go + where + go :: a -> Cofree f a + go a = let node = deferCofree \_ -> Tuple a (pure node) in node From 6dcb31e98cd13057a86c025e9188db7c149023e4 Mon Sep 17 00:00:00 2001 From: Alex Denko Date: Sat, 28 Feb 2026 17:19:09 -0600 Subject: [PATCH 3/4] update changelog --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 3c198ea..c179f96 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,8 @@ Breaking changes: New features: +- Added `ZipCofree` wrapper newtype, with zipping `Apply` and `Applicative` instances (#128) + Bugfixes: Other improvements: From c73559aa044695285546ed370a45219abb0dc643 Mon Sep 17 00:00:00 2001 From: Thomas Honeyman Date: Thu, 22 Oct 2026 20:06:57 +0000 Subject: [PATCH 4/4] Clean up ZipCofree and test layer-wise application --- CHANGELOG.md | 2 +- spago.yaml | 3 ++ src/Control/Comonad/ZipCofree.purs | 48 +++++++++++++-------------- test/Test/Control/Comonad/Cofree.purs | 34 +++++++++++++++++++ test/Test/Main.purs | 6 ++++ 5 files changed, 67 insertions(+), 26 deletions(-) create mode 100644 test/Test/Control/Comonad/Cofree.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index 2a84953..f622ef8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,7 +8,7 @@ Breaking changes: New features: -- Added `ZipCofree` wrapper newtype, with zipping `Apply` and `Applicative` instances (#128) +- Added the `ZipCofree` newtype wrapper with layer-wise `Apply` and `Applicative` instances (#128 by @adenko). Bugfixes: diff --git a/spago.yaml b/spago.yaml index 79ffc9b..126d131 100644 --- a/spago.yaml +++ b/spago.yaml @@ -21,7 +21,9 @@ package: - invariant: ">=6.0.0 <7.0.0" - lazy: ">=6.0.0 <7.0.0" - maybe: ">=6.0.0 <7.0.0" + - newtype: ">=5.0.0 <6.0.0" - prelude: ">=6.0.0 <7.0.0" + - safe-coerce: ">=2.0.0 <3.0.0" - tailrec: ">=6.0.0 <7.0.0" - transformers: ">=6.0.0 <7.0.0" - tuples: ">=7.0.0 <8.0.0" @@ -33,5 +35,6 @@ package: dependencies: - console: ">=6.0.0 <7.0.0" - effect: ">=4.0.0 <5.0.0" + - exceptions: ">=6.0.0 <7.0.0" - functors: ">=5.0.0 <6.0.0" workspace: {} diff --git a/src/Control/Comonad/ZipCofree.purs b/src/Control/Comonad/ZipCofree.purs index 2834741..bc539b2 100644 --- a/src/Control/Comonad/ZipCofree.purs +++ b/src/Control/Comonad/ZipCofree.purs @@ -2,56 +2,54 @@ module Control.Comonad.ZipCofree ( ZipCofree(..) ) where -import Control.Applicative (pure) -import Control.Apply (class Apply, lift2) +import Prelude + +import Control.Apply (lift2) import Control.Comonad (class Comonad) import Control.Comonad.Cofree (Cofree, deferCofree, head, tail) import Control.Extend (class Extend) import Control.Lazy as Z -import Data.Eq (class Eq, class Eq1) +import Data.Eq (class Eq1) import Data.Foldable (class Foldable) import Data.FoldableWithIndex (class FoldableWithIndex) import Data.FunctorWithIndex (class FunctorWithIndex) -import Data.Monoid (class Monoid) import Data.Newtype (class Newtype) -import Data.Ord (class Ord, class Ord1) -import Data.Semigroup (class Semigroup) +import Data.Ord (class Ord1) import Data.Traversable (class Traversable) import Data.TraversableWithIndex (class TraversableWithIndex) import Data.Tuple (Tuple(..)) -import Prelude (class Applicative, class Functor, ($)) import Safe.Coerce (coerce) -- | `ZipCofree` is a newtype around `Cofree` which provides a zippy -- | `Apply` instance. newtype ZipCofree f a = ZipCofree (Cofree f a) -derive instance newtypeZipCofree :: Newtype (ZipCofree f a) _ +derive instance Newtype (ZipCofree f a) _ -derive newtype instance semigroupZipCofree :: (Apply f, Semigroup a) => Semigroup (ZipCofree f a) -derive newtype instance monoidZipCofree :: (Applicative f, Monoid a) => Monoid (ZipCofree f a) -derive newtype instance ordZipCofree :: (Ord1 f, Ord a) => Ord (ZipCofree f a) -derive newtype instance ord1ZipCofree :: (Ord1 f) => Ord1 (ZipCofree f) -derive newtype instance eqZipCofree :: (Eq1 f, Eq a) => Eq (ZipCofree f a) -derive newtype instance eq1ZipCofree :: (Eq1 f) => Eq1 (ZipCofree f) -derive newtype instance functorZipCofree :: Functor f => Functor (ZipCofree f) -derive newtype instance functorWithIndexZipCofree :: Functor f => FunctorWithIndex Int (ZipCofree f) -derive newtype instance extendZipCofree :: Functor f => Extend (ZipCofree f) -derive newtype instance comonadZipCofree :: Functor f => Comonad (ZipCofree f) -derive newtype instance foldableZipCofree :: Foldable f => Foldable (ZipCofree f) -derive newtype instance foldableWithIndexZipCofree :: Foldable f => FoldableWithIndex Int (ZipCofree f) -derive newtype instance traversableZipCofree :: Traversable f => Traversable (ZipCofree f) -derive newtype instance traversableWithIndexZipCofree :: Traversable f => TraversableWithIndex Int (ZipCofree f) -derive newtype instance lazyZipCofree :: Z.Lazy (ZipCofree f a) +derive newtype instance (Apply f, Semigroup a) => Semigroup (ZipCofree f a) +derive newtype instance (Applicative f, Monoid a) => Monoid (ZipCofree f a) +derive newtype instance (Ord1 f, Ord a) => Ord (ZipCofree f a) +derive newtype instance Ord1 f => Ord1 (ZipCofree f) +derive newtype instance (Eq1 f, Eq a) => Eq (ZipCofree f a) +derive newtype instance Eq1 f => Eq1 (ZipCofree f) +derive newtype instance Functor f => Functor (ZipCofree f) +derive newtype instance Functor f => FunctorWithIndex Int (ZipCofree f) +derive newtype instance Functor f => Extend (ZipCofree f) +derive newtype instance Functor f => Comonad (ZipCofree f) +derive newtype instance Foldable f => Foldable (ZipCofree f) +derive newtype instance Foldable f => FoldableWithIndex Int (ZipCofree f) +derive newtype instance Traversable f => Traversable (ZipCofree f) +derive newtype instance Traversable f => TraversableWithIndex Int (ZipCofree f) +derive newtype instance Z.Lazy (ZipCofree f a) -instance applyZipCofree :: Apply f => Apply (ZipCofree f) where +instance Apply f => Apply (ZipCofree f) where apply :: forall a b. ZipCofree f (a -> b) -> ZipCofree f a -> ZipCofree f b apply = coerce go where go :: Cofree f (a -> b) -> Cofree f a -> Cofree f b go ff aa = deferCofree \_ -> Tuple (head ff $ head aa) (lift2 go (tail ff) (tail aa)) -instance applicativeZipCofree :: Applicative f => Applicative (ZipCofree f) where +instance Applicative f => Applicative (ZipCofree f) where pure :: forall a. a -> ZipCofree f a pure = coerce go where diff --git a/test/Test/Control/Comonad/Cofree.purs b/test/Test/Control/Comonad/Cofree.purs new file mode 100644 index 0000000..42395cd --- /dev/null +++ b/test/Test/Control/Comonad/Cofree.purs @@ -0,0 +1,34 @@ +module Test.Control.Comonad.Cofree where + +import Prelude + +import Control.Comonad.Cofree (Cofree, head, mkCofree, tail) +import Control.Comonad.ZipCofree (ZipCofree(..)) +import Data.Maybe (Maybe(..)) +import Effect (Effect) +import Effect.Exception (throw) + +labels :: forall a. Int -> Cofree Maybe a -> Array a +labels depth tree + | depth <= 0 = [] + | otherwise = [ head tree ] <> case tail tree of + Nothing -> [] + Just child -> labels (depth - 1) child + +main :: Effect Unit +main = do + let + values = mkCofree 2 (Just (mkCofree 5 (Just (mkCofree 9 Nothing)))) + functions = mkCofree (_ + 10) (Just (mkCofree (_ * 3) Nothing)) + ZipCofree zipped = ZipCofree functions <*> ZipCofree values + ZipCofree shorter = ZipCofree functions <*> ZipCofree (mkCofree 7 Nothing) + ZipCofree repeated = pure 11 :: ZipCofree Maybe Int + ZipCofree unchanged = pure identity <*> ZipCofree values + unless (labels 4 zipped == [ 12, 15 ]) do + throw "ZipCofree must apply functions layer-wise and stop when functions end" + unless (labels 4 shorter == [ 17 ]) do + throw "ZipCofree must stop when values end" + unless (labels 4 repeated == [ 11, 11, 11, 11 ]) do + throw "ZipCofree pure must lazily repeat at every layer" + unless (unchanged == values) do + throw "ZipCofree must satisfy applicative identity" diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 33ffea1..e5e55d2 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -4,6 +4,7 @@ import Prelude import Effect (Effect) import Effect.Console (log) +import Test.Control.Comonad.Cofree as Cofree import Test.Control.Monad.Free.Coproduct as C import Test.Control.Monad.Free.Stratified as S import Test.Control.Monad.Free.Teletype as T @@ -22,3 +23,8 @@ main = do log "Stratified" S.main + + log "" + + log "Cofree" + Cofree.main