Draft of Trifunctor.Traversable

src/Data/Trifunctor/Traversable.hs

@@ -0,0 +1,112 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+
+module Data.Trifunctor.Traversable
+  ( Traversable (..),
+    First (..),
+    Second (..),
+  )
+where
+
+--------------------------------------------------------------------------------
+
+import Control.Applicative (Applicative (..))
+import Data.Bifunctor (Bifunctor (..))
+import Data.Functor.Contravariant (Contravariant (..))
+import Data.Kind (Constraint, Type)
+import Data.Profunctor (Profunctor (..))
+import Data.Trifunctor.Monoidal (Monoidal, Semigroupal (..), Unital (..))
+import GHC.Generics (Generic (..), Generic1, K1 (..), M1 (..), U1 (..), type (:*:) (..))
+import Prelude hiding (Traversable)
+
+--------------------------------------------------------------------------------
+
+class Traversable hkd where
+  sequence :: forall p. (forall x. Profunctor (p x), Monoidal (->) (,) () (,) () (,) () (,) () p) => hkd p -> p (hkd First) (hkd Second) (hkd Third)
+
+-- default sequence :: forall p. (Profunctor 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 = dimap 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 -> Type) -> (Type -> Type) -> Constraint
+class GTraversable p f g h i where
+  gsequence :: f x -> p (g x) (h x) (i x)
+
+instance (forall x. Profunctor (p x), GTraversable p f g h i) => GTraversable p (M1 _1 _2 f) (M1 _1 _2 g) (M1 _1 _2 h) (M1 _1 _2 i) where
+  gsequence :: M1 _1 _2 f x -> p (M1 _1 _2 g x) (M1 _1 _2 h x) (M1 _1 _2 i x)
+  -- NOTE: It looks like we need a trifunctor to make this work:
+  gsequence (M1 f) = _ $ dimap unM1 M1 $ gsequence @p @f @g @h @i f
+
+-- instance (Profunctor 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) = dimap (unFirst . unK1) (K1 . Second) f
+
+-- instance (Profunctor p, Monoidal (->) (,) () (,) () (,) () p) => GTraversable p U1 U1 U1 where
+--   gsequence :: U1 x -> p (U1 x) (U1 x)
+--   gsequence U1 = dimap (const ()) (const U1) $ introduce @_ @_ @() ()
+
+-- instance (Profunctor 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 dimap (\(x :*: y) -> (x, y)) (uncurry (:*:)) $ combine (phkd1, phkd2)
+
+--------------------------------------------------------------------------------
+
+type First :: Type -> Type -> Type -> Type
+newtype First x y z = 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 y) where
+  contramap :: (a' -> a) -> First x y a -> First x y a'
+  contramap _ (First x) = First x
+
+instance (Monoid x) => Applicative (First x y) where
+  pure :: a -> First x y a
+  pure _ = First mempty
+
+  liftA2 :: (a -> b -> c) -> First x y a -> First x y b -> First x y c
+  liftA2 _ (First x) (First x') = First (x <> x')
+
+instance Bifunctor (First x) where
+  bimap :: (a -> b) -> (c -> d) -> First x a c -> First x b d
+  bimap _ _ (First x) = First x
+
+--------------------------------------------------------------------------------
+
+type Second :: Type -> Type -> Type -> Type
+newtype Second x y z = Second {unSecond :: y}
+  deriving stock (Generic, Generic1, Functor)
+  deriving newtype (Bounded, Show, Read, Eq, Ord, Enum, Num, Integral, Real, Semigroup, Monoid)
+
+instance (Monoid y) => Applicative (Second x y) where
+  pure :: a -> Second x y a
+  pure _ = Second mempty
+
+  liftA2 :: (a -> b -> c) -> Second x y a -> Second x y b -> Second x y c
+  liftA2 _ (Second y) (Second y') = Second (y <> y')
+
+instance Bifunctor (Second x) where
+  bimap :: (a -> b) -> (c -> d) -> Second x a c -> Second x b d
+  bimap f _ (Second a) = Second $ f a
+
+--------------------------------------------------------------------------------
+
+type Third :: Type -> Type -> Type -> Type
+newtype Third x y z = Third {unThird :: z}
+  deriving stock (Generic, Generic1, Functor)
+  deriving newtype (Bounded, Show, Read, Eq, Ord, Enum, Num, Integral, Real, Semigroup, Monoid)
+
+instance Applicative (Third x y) where
+  pure :: a -> Third x y a
+  pure = Third
+
+  liftA2 :: (a -> b -> c) -> Third x y a -> Third x y b -> Third x y c
+  liftA2 f (Third y) (Third y') = Third (f y y')
+
+instance Bifunctor (Third x) where
+  bimap :: (a -> b) -> (c -> d) -> Third x a c -> Third x b d
+  bimap _ g (Third y) = Third (g y)