Implements Traversable Phase 1 (Tupling)

.github/workflows/cabal.yml

@@ -20,7 +20,7 @@ jobs:
     strategy:
       matrix:
         cabal: ["3.6", "3.10"]
-        ghc: ["9.0.2", "9.2.8", "9.4.8", "9.6.3"]
+        ghc: ["9.2.8", "9.4.8", "9.6.3"]
 
     steps:
       - name: Checkout

cabal.project

@@ -0,0 +1,6 @@
+packages: .
+
+source-repository-package
+  type: git
+  location: https://github.com/solomon-b/kindly-functors.git
+  tag: 26fdb99ef92124241e38e6f4511961ad2f9fb920

flake.nix

@@ -10,13 +10,28 @@
     let
       ghcVersion = "963";
       compiler = "ghc${ghcVersion}";
-      overlay = import ./overlay.nix;
-      overlays = [ overlay ];
     in
     flake-utils.lib.eachDefaultSystem
       (system:
         let
-          pkgs = import nixpkgs { inherit system overlays; };
+          pkgs = import nixpkgs { inherit system; };
+          hsPkgs = pkgs.haskell.packages.${compiler}.override (old: {
+            overrides = pkgs.lib.composeExtensions (old.overrides or (_: _: { }))
+              (hfinal: hprev: {
+                kindly-functors = hfinal.callCabal2nix "kindly-functors" (pkgs.fetchFromGitHub {
+                  owner = "solomon-b";
+                  repo = "kindly-functors";
+                  rev = "26fdb99ef92124241e38e6f4511961ad2f9fb920";
+                  sha256 = "sha256-nZHERb1QA3XtRZWEcIoq8P4atOBioE7cRrJqrjkw9m0=";
+                }) {};
+                monoidal-functors = (hfinal.callCabal2nix "monoidal-functors" ./. { }).overrideScope (hfinal': hprev': {
+                  bifunctors = hfinal.bifunctors_5_6_1;
+                  semigroupoids = hfinal.semigroupoids_6_0_0_1.overrideScope (hfinal': hprev': {
+                    bifunctors = hfinal.bifunctors_5_6_1;
+                  });
+                });
+              });
+          });
         in
         rec {
           devShell = pkgs.mkShell {
@@ -31,11 +46,9 @@
 
           formatter = pkgs.nixpkgs-fmt;
           packages = flake-utils.lib.flattenTree {
-            monoidal-functors = pkgs.haskellPackages.monoidal-functors;
+            monoidal-functors = hsPkgs.monoidal-functors;
           };
 
           defaultPackage = packages.monoidal-functors;
-        }) // {
-      overlays.default = overlay;
-    };
+        });
 }

monoidal-functors.cabal

@@ -12,8 +12,7 @@ homepage:            http://github.com/solomon-b/monoidal-functors
 build-type:          Simple
 extra-source-files:  CHANGELOG.md
 description:         A typeclass hierarchy for monoidal functors.
-tested-with:   GHC == 9.0.2
-             , GHC == 9.2.8
+tested-with:   GHC == 9.2.8
              , GHC == 9.4.8
              , GHC == 9.6.3
 source-repository head
@@ -53,6 +52,7 @@ library
   build-depends:
     base                          >= 4.12 && < 5,
     bifunctors                    >= 5.6.1 && < 6,
+    kindly-functors,
     tagged                        >= 0.8.7 && < 0.9,
     transformers                  >= 0.5.6 && < 0.7,
     comonad                       >= 5.0.8 && < 6,
@@ -72,12 +72,15 @@ library
     Data.Bifunctor.Module
     Data.Bifunctor.Monoidal
     Data.Bifunctor.Monoidal.Specialized
+    Data.Bifunctor.Traversable
     Data.Functor.Invariant
     Data.Functor.Module
     Data.Functor.Monoidal
     Data.Functor.Monoidal.Specialized
+    Data.Functor.Traversable
     Data.Trifunctor.Module
     Data.Trifunctor.Monoidal
+    Data.Trifunctor.Traversable
 
   ghc-options:
     -Wall

src/Data/Bifunctor/Traversable.hs

@@ -0,0 +1,120 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+
+module Data.Bifunctor.Traversable
+  ( Traversable (..),
+    First (..),
+    Second (..),
+    -- F (..),
+    -- ffirst,
+    -- farrow,
+    -- sequencedF,
+    -- example,
+  )
+where
+
+--------------------------------------------------------------------------------
+
+import Control.Applicative
+import Data.Bifunctor (Bifunctor (..))
+import Data.Bifunctor.Monoidal (Monoidal, Semigroupal (..), Unital (..))
+import Data.Functor.Contravariant (Contravariant (..), Op (..))
+import Data.Kind (Constraint, Type)
+import GHC.Generics (Generic (..), Generic1, K1 (..), M1 (..), U1 (..), type (:*:) (..))
+import Kindly qualified
+import Prelude hiding (Traversable (..))
+
+--------------------------------------------------------------------------------
+
+class Traversable hkd where
+  sequence :: forall p. (Kindly.Bifunctor Op (->) p, Monoidal (->) (,) () (,) () (,) () p) => hkd p -> p (hkd First) (hkd Second)
+  default sequence :: forall p. (Kindly.Bifunctor Op (->) p, Monoidal (->) (,) () (,) () (,) () p, Generic (hkd p), Generic (hkd First), Generic (hkd Second), GTraversable p (Rep (hkd p)) (Rep (hkd First)) (Rep (hkd Second))) => hkd p -> p (hkd First) (hkd Second)
+  sequence = Kindly.bimap (Op from) to . gsequence @p @(Rep (hkd p)) @(Rep (hkd First)) @(Rep (hkd Second)) . from
+
+type GTraversable :: (Type -> Type -> Type) -> (Type -> Type) -> (Type -> Type) -> (Type -> Type) -> Constraint
+class GTraversable p f g h where
+  gsequence :: f x -> p (g x) (h x)
+
+instance (Kindly.Bifunctor Op (->) p, GTraversable p f g h) => GTraversable p (M1 _1 _2 f) (M1 _1 _2 g) (M1 _1 _2 h) where
+  gsequence :: M1 _1 _2 f x -> p (M1 _1 _2 g x) (M1 _1 _2 h x)
+  gsequence (M1 f) = Kindly.bimap (Op unM1) M1 $ gsequence f
+
+instance (Kindly.Bifunctor Op (->) p) => GTraversable p (K1 _1 (p a b)) (K1 _1 (First a b)) (K1 _1 (Second a b)) where
+  gsequence :: K1 _1 (p a b) x -> p (K1 _1 (First a b) x) (K1 _1 (Second a b) x)
+  gsequence (K1 f) = Kindly.bimap (Op $ unFirst . unK1) (K1 . Second) f
+
+instance (Kindly.Bifunctor Op (->) p, Monoidal (->) (,) () (,) () (,) () p) => GTraversable p U1 U1 U1 where
+  gsequence :: U1 x -> p (U1 x) (U1 x)
+  gsequence U1 = Kindly.bimap (Op $ const ()) (const U1) $ introduce @_ @_ @() ()
+
+instance (Kindly.Bifunctor Op (->) p, Monoidal (->) (,) () (,) () (,) () p, GTraversable p f1 g1 h1, GTraversable p f2 g2 h2) => GTraversable p (f1 :*: f2) (g1 :*: g2) (h1 :*: h2) where
+  gsequence :: (:*:) f1 f2 x -> p ((:*:) g1 g2 x) ((:*:) h1 h2 x)
+  gsequence (hkd1 :*: hkd2) =
+    let phkd1 = gsequence hkd1
+        phkd2 = gsequence hkd2
+     in Kindly.bimap (Op $ \(x :*: y) -> (x, y)) (uncurry (:*:)) $ combine (phkd1, phkd2)
+
+--------------------------------------------------------------------------------
+
+type First :: Type -> Type -> Type
+newtype First x y = First {unFirst :: x}
+  deriving stock (Generic, Generic1, Functor)
+  deriving newtype (Bounded, Show, Read, Eq, Ord, Enum, Num, Integral, Real, Semigroup, Monoid)
+
+instance Contravariant (First x) where
+  contramap :: (a' -> a) -> First x a -> First x a'
+  contramap _ (First x) = First x
+
+instance (Monoid x) => Applicative (First x) where
+  pure :: a -> First x a
+  pure _ = First mempty
+
+  liftA2 :: (a -> b -> c) -> First x a -> First x b -> First x c
+  liftA2 _ (First x) (First x') = First (x <> x')
+
+instance Bifunctor First where
+  bimap :: (a -> b) -> (c -> d) -> First a c -> First b d
+  bimap f _ (First x) = First (f x)
+
+--------------------------------------------------------------------------------
+
+type Second :: Type -> Type -> Type
+newtype Second x y = Second {unSecond :: y}
+  deriving stock (Generic, Generic1, Functor)
+  deriving newtype (Bounded, Show, Read, Eq, Ord, Enum, Num, Integral, Real, Semigroup, Monoid)
+
+instance Applicative (Second x) where
+  pure :: a -> Second x a
+  pure = Second
+
+  liftA2 :: (a -> b -> c) -> Second x a -> Second x b -> Second x c
+  liftA2 f (Second y) (Second y') = Second (f y y')
+
+instance Bifunctor Second where
+  bimap :: (a -> b) -> (c -> d) -> Second a c -> Second b d
+  bimap _ g (Second y) = Second (g y)
+
+--------------------------------------------------------------------------------
+-- Example:
+
+-- type F :: (Type -> Type -> Type) -> Type
+-- data F p = F {foo :: p Int String, bar :: p Bool String, baz :: p Bool Bool}
+--   deriving stock (Generic)
+--   deriving anyclass (Traversable)
+
+-- deriving instance (forall x y. (Show x, Show y) => Show (p x y)) => Show (F p)
+
+-- farrow :: F (->)
+-- farrow = F {foo = show, bar = show, baz = id}
+
+-- ffirst :: F First
+-- ffirst = F {foo = First 0, bar = First True, baz = First True}
+
+-- sequencedF :: (->) (F First) (F Second)
+-- sequencedF = sequence farrow
+
+-- example :: F Second
+-- example = sequencedF ffirst

src/Data/Functor/Traversable.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+
+module Data.Functor.Traversable
+  ( Traversable (..),
+  )
+where
+
+--------------------------------------------------------------------------------
+
+import Control.Monad.Identity (Identity (..))
+import Data.Functor.Monoidal (Monoidal, Semigroupal (..), Unital (..))
+import Data.Kind (Constraint, Type)
+import GHC.Generics
+import Kindly qualified
+import Prelude hiding (Traversable (..))
+
+--------------------------------------------------------------------------------
+
+class Traversable hkd where
+  sequence :: forall f. (Kindly.Functor (->) f, Monoidal (->) (,) () (,) () f) => hkd f -> f (hkd Identity)
+  default sequence :: forall p. (Kindly.Functor (->) p, Monoidal (->) (,) () (,) () p, Generic (hkd p), Generic (hkd Identity), GTraversable p (Rep (hkd p)) (Rep (hkd Identity))) => hkd p -> p (hkd Identity)
+  sequence = Kindly.fmap to . gsequence @p @(Rep (hkd p)) @(Rep (hkd Identity)) . from
+
+type GTraversable :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) -> Constraint
+class GTraversable f g h where
+  gsequence :: g x -> f (h x)
+
+instance (Kindly.Functor (->) f, GTraversable f g h) => GTraversable f (M1 _1 _2 g) (M1 _1 _2 h) where
+  gsequence :: M1 _1 _2 g x -> f (M1 _1 _2 h x)
+  gsequence (M1 f) = Kindly.fmap M1 $ gsequence @f @g @h f
+
+instance (Kindly.Functor (->) f) => GTraversable f (K1 _1 (f a)) (K1 _1 (Identity a)) where
+  gsequence :: K1 _1 (f a) x -> f (K1 _1 (Identity a) x)
+  gsequence (K1 f) = Kindly.fmap (K1 . Identity) f
+
+instance (Kindly.Functor (->) f, Monoidal (->) (,) () (,) () f) => GTraversable f U1 U1 where
+  gsequence :: U1 x -> f (U1 x)
+  gsequence U1 = Kindly.fmap (const U1) $ introduce @_ @() ()
+
+instance (Kindly.Functor (->) f, Monoidal (->) (,) () (,) () f, GTraversable f g1 h1, GTraversable f g2 h2) => GTraversable f (g1 :*: g2) (h1 :*: h2) where
+  gsequence :: (:*:) g1 g2 x -> f ((:*:) h1 h2 x)
+  gsequence (hkd1 :*: hkd2) = Kindly.fmap (uncurry (:*:)) $ combine @_ @(,) (gsequence hkd1, gsequence hkd2)