From 718f94d570c0854606b337d982582ab727258c88 Mon Sep 17 00:00:00 2001
From: solomon <ssbothwell@gmail.com>
Date: Fri, 9 Dec 2022 13:14:11 -0800
Subject: [PATCH 1/3] HKD Proof of Concept

---
 chat-bots/chat-bots.cabal               |   4 +
 chat-bots/src/Data/Align2.hs            |  14 ++
 chat-bots/src/Data/Bifunctor/Const2.hs  |  27 ++++
 chat-bots/src/Data/Trifunctor/Barbie.hs | 163 ++++++++++++++++++++++++
 4 files changed, 208 insertions(+)
 create mode 100644 chat-bots/src/Data/Align2.hs
 create mode 100644 chat-bots/src/Data/Bifunctor/Const2.hs
 create mode 100644 chat-bots/src/Data/Trifunctor/Barbie.hs

diff --git a/chat-bots/chat-bots.cabal b/chat-bots/chat-bots.cabal
index 1ecdde5..db599ea 100644
--- a/chat-bots/chat-bots.cabal
+++ b/chat-bots/chat-bots.cabal
@@ -48,6 +48,7 @@ common common-settings
 common common-libraries
   build-depends:
     , base           >=2 && <5
+    , bifunctors
     , bytestring
     , matrix-client
     , network-uri
@@ -65,6 +66,9 @@ library
 
   hs-source-dirs:  src
   exposed-modules:
+    Data.Align2
+    Data.Bifunctor.Const2
+    Data.Trifunctor.Barbie
     Data.Chat.Bot
     Data.Chat.Bot.Monoidal
     Data.Chat.Bot.Context
diff --git a/chat-bots/src/Data/Align2.hs b/chat-bots/src/Data/Align2.hs
new file mode 100644
index 0000000..ebc4814
--- /dev/null
+++ b/chat-bots/src/Data/Align2.hs
@@ -0,0 +1,14 @@
+module Data.Align2
+  ( Semialign2 (..),
+  )
+where
+
+--------------------------------------------------------------------------------
+
+import Data.Chat.Utils
+
+--------------------------------------------------------------------------------
+
+class Semialign2 p where
+  align2 :: p a b -> p c d -> p (a /+\ c) (b /+\ d)
+  alignWith2 :: (a /+\ c -> e) -> (b /+\ d -> f) -> p a b -> p c d -> p e f
diff --git a/chat-bots/src/Data/Bifunctor/Const2.hs b/chat-bots/src/Data/Bifunctor/Const2.hs
new file mode 100644
index 0000000..3ec8ba4
--- /dev/null
+++ b/chat-bots/src/Data/Bifunctor/Const2.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE StandaloneDeriving #-}
+
+module Data.Bifunctor.Const2
+  ( Const2 (..),
+  )
+where
+
+--------------------------------------------------------------------------------
+
+import Control.Applicative (Applicative (..))
+import Data.String (IsString)
+import GHC.Generics (Generic)
+
+--------------------------------------------------------------------------------
+
+newtype Const2 a b c = Const2 a
+  deriving stock (Functor)
+  deriving newtype (Generic, Semigroup, Monoid)
+
+instance Monoid m => Applicative (Const2 m b) where
+  pure :: Monoid m => a -> Const2 m b a
+  pure _ = Const2 mempty
+
+  liftA2 :: Monoid m => (a -> b1 -> c) -> Const2 m b a -> Const2 m b b1 -> Const2 m b c
+  liftA2 _ (Const2 x) (Const2 y) = Const2 (x <> y)
+
+deriving instance IsString a => IsString (Const2 a b c)
diff --git a/chat-bots/src/Data/Trifunctor/Barbie.hs b/chat-bots/src/Data/Trifunctor/Barbie.hs
new file mode 100644
index 0000000..e2c73ac
--- /dev/null
+++ b/chat-bots/src/Data/Trifunctor/Barbie.hs
@@ -0,0 +1,163 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Data.Trifunctor.Barbie where
+
+-- ( First (..),
+--   Second (..),
+--   Optional (..),
+--   traverseThese,
+--   zipMyApp,
+-- )
+
+--------------------------------------------------------------------------------
+
+import Data.Bifunctor.Const2 (Const2 (..))
+import Data.Bifunctor.Product (Product (..))
+import Data.Chat.Bot (Bot)
+import Data.Chat.Serialization (TextSerializer)
+import Data.Chat.Serialization qualified as S
+import Data.Chat.Utils (type (/+\))
+import Data.Kind (Type)
+import Data.Profunctor (Profunctor (..))
+import Data.Text (Text)
+import Data.Text qualified as Text
+
+--------------------------------------------------------------------------------
+
+class FunctorB2 (b :: (k -> k' -> Type) -> Type) where
+  b2map :: (forall x y. f x y -> g x y) -> b f -> b g
+
+instance FunctorB2 MyApp where
+  b2map :: (forall x y. f x y -> g x y) -> MyApp f -> MyApp g
+  b2map nat MyApp {..} = MyApp {helloBot' = nat helloBot', coinFlipBot' = nat coinFlipBot'}
+
+--------------------------------------------------------------------------------
+
+class FunctorB2 b => ApplicativeB2 (b :: (Type -> Type -> Type) -> Type) where
+  b2pure :: Profunctor f => f () () -> b f
+  b2prod :: b f -> b g -> b (f `Product` g)
+
+instance ApplicativeB2 MyApp where
+  b2pure :: Profunctor f => f () () -> MyApp f
+  b2pure fxy = MyApp (lmap (const ()) fxy) (lmap (const ()) fxy)
+
+  b2prod :: MyApp f -> MyApp g -> MyApp (Product f g)
+  b2prod (MyApp x1 y1) (MyApp x2 y2) = MyApp (Pair x1 x2) (Pair y1 y2)
+
+--------------------------------------------------------------------------------
+
+class FunctorB2 b => TraversableB2 (b :: (k -> k' -> Type) -> Type) where
+  b2traverse :: Applicative e => (forall x y. f x y -> e (g x y)) -> b f -> e (b g)
+
+instance TraversableB2 MyApp where
+  b2traverse :: Applicative e => (forall x y. f x y -> e (g x y)) -> MyApp f -> e (MyApp g)
+  b2traverse f MyApp {..} = MyApp <$> f helloBot' <*> f coinFlipBot'
+
+--------------------------------------------------------------------------------
+
+newtype First a b = First (Maybe a)
+
+newtype Second a b = Second (Maybe b)
+
+newtype Optional p a b = Both (Maybe (p a b))
+
+--------------------------------------------------------------------------------
+
+-- TODO: Replace @align2'@ with @Semialign2@ instance.
+traverseThese ::
+  ( Profunctor p,
+    Applicative (p (MyApp First))
+  ) =>
+  (forall a b c d. p a b -> p c d -> p (a /+\ c) (b /+\ d)) ->
+  MyApp p ->
+  p (MyApp First) (MyApp Second)
+traverseThese align2' barbie = b2traverse _ barbie
+
+b2ZipWith :: ApplicativeB2 barbie => (forall x y. p x y -> q x y -> pq x y) -> barbie p -> barbie q -> barbie pq
+b2ZipWith f bp bq = b2map (\(Pair fa ga) -> f fa ga) (bp `b2prod` bq)
+
+--------------------------------------------------------------------------------
+
+-- | Convert a 'FunctorB' into a 'FunctorT' and vice-versa.
+newtype Flip b l r = Flip {runFlip :: b r l}
+  deriving (Eq, Ord, Read, Show)
+
+--------------------------------------------------------------------------------
+-- HKD Bot Proof of Concept
+
+-- TODO: Add a state param
+data MyApp p = MyApp
+  { helloBot' :: p Text (),
+    coinFlipBot' :: p Bool ()
+  }
+
+-- | Packing the HKD with 'Const2 Text' gives us labels for the 'Bot'
+-- subroutines of our HKD. This could be constructed with GHC Generics
+-- or Template Haskell.
+myAppNames :: MyApp (Const2 Text)
+myAppNames =
+  MyApp
+    { helloBot' = "Hello Bot",
+      coinFlipBot' = "Coin Flip Bot"
+    }
+
+-- | Packing the HKD with 'Serializer' gives us serializers for the
+-- 'Bot' subroutines of our HKD.
+myAppSerializer :: MyApp TextSerializer
+myAppSerializer =
+  MyApp
+    { helloBot' = S.Serializer (\t -> if t == "cofree-bot" then Just () else Nothing) id,
+      coinFlipBot' = S.Serializer (\t -> if t == "flip a coin" then Just () else Nothing) (Text.pack . show)
+    }
+
+-- | 'Serializer' subroutine of 'MyApp' augmented with label prefixes
+-- for each subroutine.
+myAppSerializer' :: MyApp TextSerializer
+myAppSerializer' = b2ZipWith (\(Const2 x) -> S.prefix x) myAppNames myAppSerializer
+
+-- | By traversing an HKD of 'Serializer' we can produce an actual
+-- 'Serializer'.
+actualSerializer :: TextSerializer (MyApp First) (MyApp Second)
+actualSerializer = undefined (S./+\) myAppSerializer'
+
+actualSerializer' :: MyApp TextSerializer -> TextSerializer (MyApp First) (MyApp Second)
+actualSerializer' (MyApp (S.Serializer par1 pri1) (S.Serializer par2 pri2)) = S.Serializer parser printer
+  where
+    parser :: Text -> Maybe (MyApp Second)
+    parser input =
+      case (par1 input, par2 input) of
+        (Nothing, Nothing) -> Nothing
+        (Just x, Nothing) -> Just $ MyApp (Second (Just x)) (Second Nothing)
+        (Nothing, Just y) -> Just $ MyApp (Second Nothing) (Second (Just y))
+        (Just x, Just y) -> Just $ MyApp (Second (Just x)) (Second (Just y))
+
+    printer :: MyApp First -> Text
+    printer (MyApp (First Nothing) (First Nothing)) = mempty
+    printer (MyApp (First (Just x)) (First Nothing)) = pri1 x
+    printer (MyApp (First Nothing) (First (Just y))) = pri2 y
+    printer (MyApp (First (Just x)) (First (Just y))) = pri1 x <> "\n" <> pri2 y
+
+-- | Packing the HKD with 'Bot' gives us the bot subroutinesf for our
+-- HKD.
+myAppBot :: Monad m => MyApp (Flip (Bot m s))
+myAppBot =
+  MyApp
+    { helloBot' = Flip undefined,
+      coinFlipBot' = Flip undefined
+    }
+
+-- NOTE: This doesn't typecheck at the moment due to the state @s@
+-- getting tensored.
+--
+-- -- | By traversing the HKD of 'Bot' we can produce an actual 'Bot'.
+-- actualBot :: Bot m (s /\ s') (MyApp Second) (MyApp First)
+-- actualBot = runFlip $ traverseThese (\(Flip x) (Flip y) -> Flip (x M./+\ y)) myAppBot
+
+-- | Sample serialized output from 'actualBot'.
+exampleOutput :: MyApp First
+exampleOutput =
+  MyApp
+    { helloBot' = First $ Just "you talking to me punk?",
+      coinFlipBot' = First Nothing
+    }

From 29e6ae69d9de224ea16dbde58064d80a9ee45ed3 Mon Sep 17 00:00:00 2001
From: solomon <ssbothwell@gmail.com>
Date: Thu, 9 Feb 2023 12:06:34 -0800
Subject: [PATCH 2/3] x

---
 chat-bots/chat-bots.cabal                    |   3 +
 chat-bots/src/Data/Align2.hs                 |  26 ++-
 chat-bots/src/Data/Bifunctor/Const2.hs       |   2 +-
 chat-bots/src/Data/Bifunctor/HKD.hs          |  50 +++++
 chat-bots/src/Data/Chat/Bot/Serialization.hs |  11 +-
 chat-bots/src/Data/Chat/Utils.hs             |   9 +
 chat-bots/src/Data/Functor/HKD.hs            |  40 ++++
 chat-bots/src/Data/Trifunctor/Barbie.hs      | 211 ++++++++++++-------
 8 files changed, 265 insertions(+), 87 deletions(-)
 create mode 100644 chat-bots/src/Data/Bifunctor/HKD.hs
 create mode 100644 chat-bots/src/Data/Functor/HKD.hs

diff --git a/chat-bots/chat-bots.cabal b/chat-bots/chat-bots.cabal
index db599ea..700d309 100644
--- a/chat-bots/chat-bots.cabal
+++ b/chat-bots/chat-bots.cabal
@@ -67,7 +67,9 @@ library
   hs-source-dirs:  src
   exposed-modules:
     Data.Align2
+    Data.Functor.HKD
     Data.Bifunctor.Const2
+    Data.Bifunctor.HKD
     Data.Trifunctor.Barbie
     Data.Chat.Bot
     Data.Chat.Bot.Monoidal
@@ -89,6 +91,7 @@ library
     , http-client
     , lens
     , monad-loops
+    , monoidal-functors
     , mtl
     , pretty-simple
     , process
diff --git a/chat-bots/src/Data/Align2.hs b/chat-bots/src/Data/Align2.hs
index ebc4814..0485741 100644
--- a/chat-bots/src/Data/Align2.hs
+++ b/chat-bots/src/Data/Align2.hs
@@ -5,10 +5,28 @@ where
 
 --------------------------------------------------------------------------------
 
-import Data.Chat.Utils
+import Data.Bifunctor
+import Data.These (These (..))
 
 --------------------------------------------------------------------------------
 
-class Semialign2 p where
-  align2 :: p a b -> p c d -> p (a /+\ c) (b /+\ d)
-  alignWith2 :: (a /+\ c -> e) -> (b /+\ d -> f) -> p a b -> p c d -> p e f
+class Bifunctor p => Semialign2 p where
+  {-# MINIMAL (align2 | alignWith2) #-}
+  align2 :: p a b -> p c d -> p (These a c) (These b d)
+  align2 = alignWith2 id id
+
+  alignWith2 :: (These a c -> e) -> (These b d -> f) -> p a b -> p c d -> p e f
+  alignWith2 f g ab cd = bimap f g $ align2 ab cd
+
+instance Semialign2 (,) where
+  align2 :: (a, b) -> (c, d) -> (These a c, These b d)
+  align2 (a, b) (c, d) = (These a c, These b d)
+
+instance Semialign2 Either where
+  align2 :: Either a b -> Either c d -> Either (These a c) (These b d)
+  align2 ab cd = case (ab, cd) of
+    (Left a, Left c) -> Left (These a c)
+    -- Note: Arbitrary left bias in these two case:
+    (Left a, Right _d) -> Left (This a)
+    (Right _b, Left c) -> Left (That c)
+    (Right b, Right d) -> Right (These b d)
diff --git a/chat-bots/src/Data/Bifunctor/Const2.hs b/chat-bots/src/Data/Bifunctor/Const2.hs
index 3ec8ba4..b477581 100644
--- a/chat-bots/src/Data/Bifunctor/Const2.hs
+++ b/chat-bots/src/Data/Bifunctor/Const2.hs
@@ -14,7 +14,7 @@ import GHC.Generics (Generic)
 --------------------------------------------------------------------------------
 
 newtype Const2 a b c = Const2 a
-  deriving stock (Functor)
+  deriving stock (Show, Functor)
   deriving newtype (Generic, Semigroup, Monoid)
 
 instance Monoid m => Applicative (Const2 m b) where
diff --git a/chat-bots/src/Data/Bifunctor/HKD.hs b/chat-bots/src/Data/Bifunctor/HKD.hs
new file mode 100644
index 0000000..6c00c5b
--- /dev/null
+++ b/chat-bots/src/Data/Bifunctor/HKD.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE GADTs #-}
+
+module Data.Bifunctor.HKD where
+
+--------------------------------------------------------------------------------
+
+import Control.Category.Tensor
+import Data.Bifunctor
+import Data.Bifunctor.Monoidal
+import Data.Kind
+import Data.Profunctor
+
+--------------------------------------------------------------------------------
+
+-- | Maps a list of pairs of types using the given type constructor,
+-- then folds the list using the provided monoidal structure on Types.
+--
+-- __Examples:__
+--
+-- >>> :{
+--  let ex1 :: FoldMap These Void First ['((), Bool), '((), Text)]
+--      ex1 = Cons $ This (First ())
+-- :}
+--
+-- >>> :{
+--  let ex2 :: FoldMap These Void First ['((), Bool), '((), Text)]
+--      ex2 = Cons $ That $ Cons $ This $ First ()
+--
+-- >>> :{
+--  let ex3 :: FoldMap These Void First ['((), Bool), '((), Text)]
+--      ex3 = Cons $ These (First ()) $ Cons $ This $ First ()
+-- :}
+type FoldMap :: (Type -> Type -> Type) -> Type -> (Type -> Type -> Type) -> [(Type, Type)] -> Type
+data FoldMap t i f xs where
+  Nil :: {unNil :: i} -> FoldMap t i f '[]
+  Cons :: {unCons :: (p x y) `t` (FoldMap t i p xs)} -> FoldMap t i p ('(x, y) ': xs)
+
+data First a b = First {unFirst :: a}
+
+data Second a b = Second {unSecond :: b}
+
+sequenceFoldMapB :: (Bifunctor p, Monoidal (->) t1 i1 t2 i2 to io p) => FoldMap to io p xs -> p (FoldMap t1 i1 First xs) (FoldMap t2 i2 Second xs)
+sequenceFoldMapB = \case
+  Nil i -> bimap Nil Nil $ introduce i
+  Cons t -> bimap Cons Cons $ combine $ gbimap (gbimap First Second) sequenceFoldMapB t
+
+sequenceFoldMapP :: (Profunctor p, Monoidal (->) t1 i1 t2 i2 to io p) => FoldMap to io p xs -> p (FoldMap t1 i1 First xs) (FoldMap t2 i2 Second xs)
+sequenceFoldMapP = \case
+  Nil i -> dimap unNil Nil $ introduce i
+  Cons t -> dimap unCons Cons $ combine $ gbimap (dimap unFirst Second) sequenceFoldMapP t
diff --git a/chat-bots/src/Data/Chat/Bot/Serialization.hs b/chat-bots/src/Data/Chat/Bot/Serialization.hs
index c6e1be9..62db524 100644
--- a/chat-bots/src/Data/Chat/Bot/Serialization.hs
+++ b/chat-bots/src/Data/Chat/Bot/Serialization.hs
@@ -7,11 +7,12 @@ import Control.Applicative (liftA2)
 import Control.Monad ((>=>))
 import Control.Monad.ListT (emptyListT)
 import Data.Attoparsec.Text qualified as P
-import Data.Bifunctor (first)
+import Data.Bifunctor (first, Bifunctor (..))
 import Data.Chat.Bot (Bot (..))
 import Data.Chat.Utils (can, type (/+\))
 import Data.Text (Text)
 import Data.These (These (..), these)
+import Data.Profunctor
 
 --------------------------------------------------------------------------------
 
@@ -30,6 +31,14 @@ applySerializer (Bot bot) (Serializer parser printer) = Bot $ \s i ->
 -- | Bidirectional serializer from 'Server' I/O to 'Bot' I/O.
 data Serializer so si bo bi = Serializer
   {parser :: so -> Maybe bi, printer :: bo -> si}
+  deriving Functor
+
+instance Profunctor (Serializer so si) where
+  dimap f g Serializer {..} =
+    Serializer
+      { parser = fmap (fmap g) $ parser,
+        printer = printer . f
+      }
 
 -- | A 'Serializer' whose 'Server' I/O has been specialized to 'Text'.
 type TextSerializer = Serializer Text Text
diff --git a/chat-bots/src/Data/Chat/Utils.hs b/chat-bots/src/Data/Chat/Utils.hs
index 3f9a6ac..f2540ea 100644
--- a/chat-bots/src/Data/Chat/Utils.hs
+++ b/chat-bots/src/Data/Chat/Utils.hs
@@ -23,6 +23,7 @@ module Data.Chat.Utils
     distinguish,
     PointedChoice (..),
     readFileMaybe,
+    (...),
   )
 where
 
@@ -113,3 +114,11 @@ readFileMaybe :: String -> IO (Maybe Text)
 readFileMaybe path =
   fmap Just (Text.IO.readFile path)
     `catch` \e -> if isDoesNotExistError e then pure Nothing else throwIO e
+
+--------------------------------------------------------------------------------
+
+infixr 8 ...
+
+-- | The infamous blackbird operator
+(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
+(...) = (.) . (.)
diff --git a/chat-bots/src/Data/Functor/HKD.hs b/chat-bots/src/Data/Functor/HKD.hs
new file mode 100644
index 0000000..9134d79
--- /dev/null
+++ b/chat-bots/src/Data/Functor/HKD.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module Data.Functor.HKD where
+
+--------------------------------------------------------------------------------
+
+import Control.Category.Tensor
+import Data.Functor.Identity
+import Data.Functor.Monoidal
+import Data.Kind
+import Data.These
+import Data.Void
+import Data.Text (Text)
+import Control.Lens (Contravariant)
+import Data.Functor.Contravariant
+
+--------------------------------------------------------------------------------
+
+type NAry :: (Type -> Type -> Type) -> Type -> (Type -> Type) -> [Type] -> Type
+data NAry t i f xs where
+  Nil :: i -> NAry t i f '[]
+  Cons :: (f x) `t` (NAry t i f xs) -> NAry t i f (x ': xs)
+
+exampleEither :: NAry Either Void Identity '[Int, Bool]
+exampleEither = Cons (Left 1)
+
+exampleEither' :: NAry Either Void Identity '[Int, Bool]
+exampleEither' = Cons (Right (Cons (Left (Identity True))))
+
+exampleThese' :: NAry These Void Identity '[Int, Bool]
+exampleThese' = Cons (These (Identity 1) (Cons (This (Identity True))))
+
+exampleThese'' :: NAry These Void Identity '[Int, Bool]
+exampleThese'' = Cons (This (Identity 1))
+
+naryCombine :: (Functor f, Monoidal (->) t1 i1 to io f) => NAry to io f xs -> f (NAry t1 i1 Identity xs)
+naryCombine = \case
+  Nil i -> fmap Nil $ introduce i
+  Cons t -> fmap Cons $ combine $ gbimap (fmap Identity) naryCombine t
diff --git a/chat-bots/src/Data/Trifunctor/Barbie.hs b/chat-bots/src/Data/Trifunctor/Barbie.hs
index e2c73ac..d1b1eae 100644
--- a/chat-bots/src/Data/Trifunctor/Barbie.hs
+++ b/chat-bots/src/Data/Trifunctor/Barbie.hs
@@ -1,5 +1,8 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE GADTs #-}
 
 module Data.Trifunctor.Barbie where
 
@@ -12,86 +15,128 @@ module Data.Trifunctor.Barbie where
 
 --------------------------------------------------------------------------------
 
+import Control.Applicative
+import Control.Category.Cartesian
+import Data.Align2
+import Data.Bifoldable
 import Data.Bifunctor.Const2 (Const2 (..))
+import Data.Bifunctor.Monoidal
+import Data.Bifunctor.Monoidal.Specialized
 import Data.Bifunctor.Product (Product (..))
+import Data.Bitraversable
+import Data.Bool
 import Data.Chat.Bot (Bot)
-import Data.Chat.Serialization (TextSerializer)
-import Data.Chat.Serialization qualified as S
-import Data.Chat.Utils (type (/+\))
+import Data.Chat.Bot.Serialization (TextSerializer)
+import Data.Chat.Bot.Serialization qualified as S
+import Data.Chat.Utils (type (/+\), can)
 import Data.Kind (Type)
 import Data.Profunctor (Profunctor (..))
 import Data.Text (Text)
-import Data.Text qualified as Text
+import Data.These
+import Data.Functor.Compose
+import Data.Functor.Identity
 
 --------------------------------------------------------------------------------
 
 class FunctorB2 (b :: (k -> k' -> Type) -> Type) where
   b2map :: (forall x y. f x y -> g x y) -> b f -> b g
 
-instance FunctorB2 MyApp where
-  b2map :: (forall x y. f x y -> g x y) -> MyApp f -> MyApp g
-  b2map nat MyApp {..} = MyApp {helloBot' = nat helloBot', coinFlipBot' = nat coinFlipBot'}
-
---------------------------------------------------------------------------------
-
 class FunctorB2 b => ApplicativeB2 (b :: (Type -> Type -> Type) -> Type) where
-  b2pure :: Profunctor f => f () () -> b f
+  b2pure :: Profunctor f => (forall x y. f x y) -> b f
   b2prod :: b f -> b g -> b (f `Product` g)
 
-instance ApplicativeB2 MyApp where
-  b2pure :: Profunctor f => f () () -> MyApp f
-  b2pure fxy = MyApp (lmap (const ()) fxy) (lmap (const ()) fxy)
-
-  b2prod :: MyApp f -> MyApp g -> MyApp (Product f g)
-  b2prod (MyApp x1 y1) (MyApp x2 y2) = MyApp (Pair x1 x2) (Pair y1 y2)
-
---------------------------------------------------------------------------------
-
 class FunctorB2 b => TraversableB2 (b :: (k -> k' -> Type) -> Type) where
   b2traverse :: Applicative e => (forall x y. f x y -> e (g x y)) -> b f -> e (b g)
 
-instance TraversableB2 MyApp where
-  b2traverse :: Applicative e => (forall x y. f x y -> e (g x y)) -> MyApp f -> e (MyApp g)
-  b2traverse f MyApp {..} = MyApp <$> f helloBot' <*> f coinFlipBot'
-
 --------------------------------------------------------------------------------
 
 newtype First a b = First (Maybe a)
 
 newtype Second a b = Second (Maybe b)
 
-newtype Optional p a b = Both (Maybe (p a b))
+newtype Both p a b = Both (Maybe (p a b))
 
 --------------------------------------------------------------------------------
 
 -- TODO: Replace @align2'@ with @Semialign2@ instance.
 traverseThese ::
   ( Profunctor p,
+    Semialign2 p,
     Applicative (p (MyApp First))
   ) =>
   (forall a b c d. p a b -> p c d -> p (a /+\ c) (b /+\ d)) ->
   MyApp p ->
   p (MyApp First) (MyApp Second)
-traverseThese align2' barbie = b2traverse _ barbie
+traverseThese align2' barbie = b2traverse undefined barbie
 
 b2ZipWith :: ApplicativeB2 barbie => (forall x y. p x y -> q x y -> pq x y) -> barbie p -> barbie q -> barbie pq
 b2ZipWith f bp bq = b2map (\(Pair fa ga) -> f fa ga) (bp `b2prod` bq)
 
 --------------------------------------------------------------------------------
 
--- | Convert a 'FunctorB' into a 'FunctorT' and vice-versa.
 newtype Flip b l r = Flip {runFlip :: b r l}
   deriving (Eq, Ord, Read, Show)
 
+instance Semigroupal (->) (,) (,) (,) f => Semigroupal (->) (,) (,) (,) (Flip f) where
+  combine :: Semigroupal (->) (,) (,) (,) f => (Flip f x y, Flip f x' y') -> Flip f (x, x') (y, y')
+  combine (Flip f1, Flip f2) = Flip $ combine (f1, f2)
+
 --------------------------------------------------------------------------------
 -- HKD Bot Proof of Concept
 
 -- TODO: Add a state param
 data MyApp p = MyApp
-  { helloBot' :: p Text (),
-    coinFlipBot' :: p Bool ()
+  { helloBot' :: p () Text,
+    coinFlipBot' :: p () Bool
   }
 
+instance FunctorB2 MyApp where
+  b2map :: (forall x y. f x y -> g x y) -> MyApp f -> MyApp g
+  b2map nat MyApp {..} = MyApp {helloBot' = nat helloBot', coinFlipBot' = nat coinFlipBot'}
+
+instance ApplicativeB2 MyApp where
+  b2pure :: Profunctor f => (forall x y. f x y) -> MyApp f
+  b2pure fxy = MyApp fxy fxy
+
+  b2prod :: MyApp f -> MyApp g -> MyApp (Product f g)
+  b2prod (MyApp x1 y1) (MyApp x2 y2) = MyApp (Pair x1 x2) (Pair y1 y2)
+
+instance TraversableB2 MyApp where
+  b2traverse :: Applicative e => (forall x y. f x y -> e (g x y)) -> MyApp f -> e (MyApp g)
+  b2traverse f MyApp {..} = MyApp <$> f helloBot' <*> f coinFlipBot'
+
+--------------------------------------------------------------------------------
+
+helloBot :: Monad m => Bot m s () Text
+helloBot = undefined
+
+coinFlipBot :: Bot IO () () Bool
+coinFlipBot = undefined
+
+-- | Packing the HKD with 'Bot' gives us the bot subroutinesf for our
+-- HKD.
+myAppBot :: Monad m => MyApp (Bot m s)
+myAppBot =
+  MyApp
+    { helloBot' = helloBot,
+      coinFlipBot' = undefined
+    }
+
+helloBotSerializer :: TextSerializer Text ()
+helloBotSerializer = undefined
+
+coinFlipSerializer :: TextSerializer Bool ()
+coinFlipSerializer = undefined
+
+-- | Packing the HKD with 'Serializer' gives us serializers for the
+-- 'Bot' subroutines of our HKD.
+myAppSerializer :: MyApp (Flip TextSerializer)
+myAppSerializer =
+  MyApp
+    { helloBot' = Flip helloBotSerializer,
+      coinFlipBot' = Flip coinFlipSerializer
+    }
+
 -- | Packing the HKD with 'Const2 Text' gives us labels for the 'Bot'
 -- subroutines of our HKD. This could be constructed with GHC Generics
 -- or Template Haskell.
@@ -102,62 +147,66 @@ myAppNames =
       coinFlipBot' = "Coin Flip Bot"
     }
 
--- | Packing the HKD with 'Serializer' gives us serializers for the
--- 'Bot' subroutines of our HKD.
-myAppSerializer :: MyApp TextSerializer
-myAppSerializer =
-  MyApp
-    { helloBot' = S.Serializer (\t -> if t == "cofree-bot" then Just () else Nothing) id,
-      coinFlipBot' = S.Serializer (\t -> if t == "flip a coin" then Just () else Nothing) (Text.pack . show)
-    }
+--------------------------------------------------------------------------------
 
--- | 'Serializer' subroutine of 'MyApp' augmented with label prefixes
--- for each subroutine.
-myAppSerializer' :: MyApp TextSerializer
-myAppSerializer' = b2ZipWith (\(Const2 x) -> S.prefix x) myAppNames myAppSerializer
+instance Show (HKD2 In) where
+  show (HKD2 x y) = "(HKD2 " <> show x <> " " <> show y <> ")"
 
--- | By traversing an HKD of 'Serializer' we can produce an actual
--- 'Serializer'.
-actualSerializer :: TextSerializer (MyApp First) (MyApp Second)
-actualSerializer = undefined (S./+\) myAppSerializer'
+instance Show (HKD2 Out) where
+  show (HKD2 x y) = "(HKD2 " <> show x <> " " <> show y <> ")"
 
-actualSerializer' :: MyApp TextSerializer -> TextSerializer (MyApp First) (MyApp Second)
-actualSerializer' (MyApp (S.Serializer par1 pri1) (S.Serializer par2 pri2)) = S.Serializer parser printer
-  where
-    parser :: Text -> Maybe (MyApp Second)
-    parser input =
-      case (par1 input, par2 input) of
-        (Nothing, Nothing) -> Nothing
-        (Just x, Nothing) -> Just $ MyApp (Second (Just x)) (Second Nothing)
-        (Nothing, Just y) -> Just $ MyApp (Second Nothing) (Second (Just y))
-        (Just x, Just y) -> Just $ MyApp (Second (Just x)) (Second (Just y))
-
-    printer :: MyApp First -> Text
-    printer (MyApp (First Nothing) (First Nothing)) = mempty
-    printer (MyApp (First (Just x)) (First Nothing)) = pri1 x
-    printer (MyApp (First Nothing) (First (Just y))) = pri2 y
-    printer (MyApp (First (Just x)) (First (Just y))) = pri1 x <> "\n" <> pri2 y
+sequenceHKD2 :: Semigroupal (->) t1 t2 (,) p => HKD2 p -> p (t1 () ()) (t2 Bool Text)
+sequenceHKD2 (HKD2 a b) = combine (a, b)
 
--- | Packing the HKD with 'Bot' gives us the bot subroutinesf for our
--- HKD.
-myAppBot :: Monad m => MyApp (Flip (Bot m s))
-myAppBot =
-  MyApp
-    { helloBot' = Flip undefined,
-      coinFlipBot' = Flip undefined
-    }
+data HKD2 f = HKD2 {a :: f () Bool, b :: f () Text}
 
--- NOTE: This doesn't typecheck at the moment due to the state @s@
--- getting tensored.
---
--- -- | By traversing the HKD of 'Bot' we can produce an actual 'Bot'.
--- actualBot :: Bot m (s /\ s') (MyApp Second) (MyApp First)
--- actualBot = runFlip $ traverseThese (\(Flip x) (Flip y) -> Flip (x M./+\ y)) myAppBot
+instance Semigroupal (->) These These (,) (Flip TextSerializer) where
+  combine :: (Flip TextSerializer x y, Flip TextSerializer x' y') -> Flip TextSerializer (These x x') (These y y')
+  combine (Flip (S.Serializer par1 pri1), Flip (S.Serializer par2 pri2)) =
+    Flip $
+      S.Serializer
+        { parser = uncurry can . (par1 &&& par2),
+          printer = these pri1 pri2 (\y y' -> pri1 y <> pri2 y')
+        }
 
--- | Sample serialized output from 'actualBot'.
-exampleOutput :: MyApp First
-exampleOutput =
-  MyApp
-    { helloBot' = First $ Just "you talking to me punk?",
-      coinFlipBot' = First Nothing
+type Optional :: ((k -> Type) -> Type) -> (k -> Type) -> Type
+newtype Optional hkd f = Optional (hkd (Compose Maybe f))
+
+
+data In a b = In (Maybe a)
+  deriving (Show)
+
+data Out a b = Out (Maybe b)
+  deriving (Show)
+
+
+sequenceSerializer :: HKD2 (Flip TextSerializer) -> TextSerializer (HKD2 Out) (HKD2 In)
+sequenceSerializer (HKD2 x y) = f $ combine (x, y)
+  where
+    f :: Flip TextSerializer (These () ()) (These Bool Text) -> TextSerializer (HKD2 Out) (HKD2 In)
+    f (Flip (S.Serializer par pri)) =
+      S.Serializer
+        { parser = fmap (these (\() -> HKD2 (In (Just ())) (In Nothing)) (\() -> HKD2 (In Nothing) (In (Just ()))) (\() () -> HKD2 (In (Just ())) (In (Just ())))) . par,
+          printer = \case
+            (HKD2 (Out Nothing) (Out Nothing)) -> mempty
+            (HKD2 (Out (Just a)) (Out Nothing)) -> pri $ This a
+            (HKD2 (Out Nothing) (Out (Just b))) -> pri $ That b
+            (HKD2 (Out (Just a)) (Out (Just b))) -> pri $ These a b
+        }
+
+serializerHKD :: HKD2 (Flip TextSerializer)
+serializerHKD =
+  HKD2
+    { a = Flip S.Serializer {parser = bool Nothing (Just ()) . (== "flip a coin"), printer = bool "tails" "heads"},
+      b = Flip S.Serializer {parser = bool Nothing (Just ()) . (== "cofree-bot"), printer = id}
     }
+
+serializer :: TextSerializer (HKD2 Out) (HKD2 In)
+serializer = sequenceSerializer serializerHKD
+
+
+data In1 a = In1 a
+data Out1 a = Out1 a
+
+--sequencer :: Semigroupal (->) (/+\) (/+\) (,) p => b p -> p (Optional b In) (Optional b Out)
+--sequencer = undefined

From 08829b881438726addf03997ccc5c28d3ea2ef81 Mon Sep 17 00:00:00 2001
From: solomon <ssbothwell@gmail.com>
Date: Mon, 13 Feb 2023 15:36:48 -0800
Subject: [PATCH 3/3] y

---
 cabal.project                                |   7 +-
 chat-bots/src/Data/Bifunctor/HKD.hs          |   2 +
 chat-bots/src/Data/Chat/Bot/Serialization.hs |  10 +
 chat-bots/src/Data/Trifunctor/Barbie.hs      | 204 +++++--------------
 4 files changed, 73 insertions(+), 150 deletions(-)

diff --git a/cabal.project b/cabal.project
index 365e648..384f591 100644
--- a/cabal.project
+++ b/cabal.project
@@ -6,4 +6,9 @@ source-repository-package
   type: git
   location: https://github.com/softwarefactory-project/matrix-client-haskell.git
   tag: 0.1.4.2
-  subdir: matrix-client
\ No newline at end of file
+  subdir: matrix-client
+
+source-repository-package
+  type: git
+  location: https://github.com/solomon-b/monoidal-functors.git
+  tag: a9770c92902a75974e52d036381437d6f9631c19
\ No newline at end of file
diff --git a/chat-bots/src/Data/Bifunctor/HKD.hs b/chat-bots/src/Data/Bifunctor/HKD.hs
index 6c00c5b..bdadad5 100644
--- a/chat-bots/src/Data/Bifunctor/HKD.hs
+++ b/chat-bots/src/Data/Bifunctor/HKD.hs
@@ -36,8 +36,10 @@ data FoldMap t i f xs where
   Cons :: {unCons :: (p x y) `t` (FoldMap t i p xs)} -> FoldMap t i p ('(x, y) ': xs)
 
 data First a b = First {unFirst :: a}
+  deriving Show
 
 data Second a b = Second {unSecond :: b}
+  deriving Show
 
 sequenceFoldMapB :: (Bifunctor p, Monoidal (->) t1 i1 t2 i2 to io p) => FoldMap to io p xs -> p (FoldMap t1 i1 First xs) (FoldMap t2 i2 Second xs)
 sequenceFoldMapB = \case
diff --git a/chat-bots/src/Data/Chat/Bot/Serialization.hs b/chat-bots/src/Data/Chat/Bot/Serialization.hs
index 62db524..d1ab600 100644
--- a/chat-bots/src/Data/Chat/Bot/Serialization.hs
+++ b/chat-bots/src/Data/Chat/Bot/Serialization.hs
@@ -13,6 +13,7 @@ import Data.Chat.Utils (can, type (/+\))
 import Data.Text (Text)
 import Data.These (These (..), these)
 import Data.Profunctor
+-- import Data.Bifunctor.Monoidal (Semigroupal (..))
 
 --------------------------------------------------------------------------------
 
@@ -40,6 +41,15 @@ instance Profunctor (Serializer so si) where
         printer = printer . f
       }
 
+-- instance Semigroupal (->) These These (,) (Flip TextSerializer) where
+--   combine :: (Flip TextSerializer x y, Flip TextSerializer x' y') -> Flip TextSerializer (These x x') (These y y')
+--   combine (Flip (Serializer par1 pri1), Flip (Serializer par2 pri2)) =
+--     Flip $
+--       Serializer
+--         { parser = uncurry can . (par1 &&& par2),
+--           printer = these pri1 pri2 (\y y' -> pri1 y <> pri2 y')
+--         }
+
 -- | A 'Serializer' whose 'Server' I/O has been specialized to 'Text'.
 type TextSerializer = Serializer Text Text
 
diff --git a/chat-bots/src/Data/Trifunctor/Barbie.hs b/chat-bots/src/Data/Trifunctor/Barbie.hs
index d1b1eae..1ceefde 100644
--- a/chat-bots/src/Data/Trifunctor/Barbie.hs
+++ b/chat-bots/src/Data/Trifunctor/Barbie.hs
@@ -1,8 +1,9 @@
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Data.Trifunctor.Barbie where
 
@@ -15,62 +16,20 @@ module Data.Trifunctor.Barbie where
 
 --------------------------------------------------------------------------------
 
-import Control.Applicative
-import Control.Category.Cartesian
-import Data.Align2
-import Data.Bifoldable
-import Data.Bifunctor.Const2 (Const2 (..))
 import Data.Bifunctor.Monoidal
 import Data.Bifunctor.Monoidal.Specialized
-import Data.Bifunctor.Product (Product (..))
-import Data.Bitraversable
 import Data.Bool
 import Data.Chat.Bot (Bot)
 import Data.Chat.Bot.Serialization (TextSerializer)
 import Data.Chat.Bot.Serialization qualified as S
-import Data.Chat.Utils (type (/+\), can)
+import Data.Chat.Utils (can)
 import Data.Kind (Type)
-import Data.Profunctor (Profunctor (..))
 import Data.Text (Text)
 import Data.These
-import Data.Functor.Compose
-import Data.Functor.Identity
-
---------------------------------------------------------------------------------
-
-class FunctorB2 (b :: (k -> k' -> Type) -> Type) where
-  b2map :: (forall x y. f x y -> g x y) -> b f -> b g
-
-class FunctorB2 b => ApplicativeB2 (b :: (Type -> Type -> Type) -> Type) where
-  b2pure :: Profunctor f => (forall x y. f x y) -> b f
-  b2prod :: b f -> b g -> b (f `Product` g)
-
-class FunctorB2 b => TraversableB2 (b :: (k -> k' -> Type) -> Type) where
-  b2traverse :: Applicative e => (forall x y. f x y -> e (g x y)) -> b f -> e (b g)
-
---------------------------------------------------------------------------------
-
-newtype First a b = First (Maybe a)
-
-newtype Second a b = Second (Maybe b)
-
-newtype Both p a b = Both (Maybe (p a b))
-
---------------------------------------------------------------------------------
-
--- TODO: Replace @align2'@ with @Semialign2@ instance.
-traverseThese ::
-  ( Profunctor p,
-    Semialign2 p,
-    Applicative (p (MyApp First))
-  ) =>
-  (forall a b c d. p a b -> p c d -> p (a /+\ c) (b /+\ d)) ->
-  MyApp p ->
-  p (MyApp First) (MyApp Second)
-traverseThese align2' barbie = b2traverse undefined barbie
-
-b2ZipWith :: ApplicativeB2 barbie => (forall x y. p x y -> q x y -> pq x y) -> barbie p -> barbie q -> barbie pq
-b2ZipWith f bp bq = b2map (\(Pair fa ga) -> f fa ga) (bp `b2prod` bq)
+import Data.Bifunctor.HKD
+import Data.Void
+import Data.Profunctor
+import Data.Bifunctor
 
 --------------------------------------------------------------------------------
 
@@ -81,132 +40,79 @@ instance Semigroupal (->) (,) (,) (,) f => Semigroupal (->) (,) (,) (,) (Flip f)
   combine :: Semigroupal (->) (,) (,) (,) f => (Flip f x y, Flip f x' y') -> Flip f (x, x') (y, y')
   combine (Flip f1, Flip f2) = Flip $ combine (f1, f2)
 
---------------------------------------------------------------------------------
--- HKD Bot Proof of Concept
-
--- TODO: Add a state param
-data MyApp p = MyApp
-  { helloBot' :: p () Text,
-    coinFlipBot' :: p () Bool
-  }
-
-instance FunctorB2 MyApp where
-  b2map :: (forall x y. f x y -> g x y) -> MyApp f -> MyApp g
-  b2map nat MyApp {..} = MyApp {helloBot' = nat helloBot', coinFlipBot' = nat coinFlipBot'}
-
-instance ApplicativeB2 MyApp where
-  b2pure :: Profunctor f => (forall x y. f x y) -> MyApp f
-  b2pure fxy = MyApp fxy fxy
-
-  b2prod :: MyApp f -> MyApp g -> MyApp (Product f g)
-  b2prod (MyApp x1 y1) (MyApp x2 y2) = MyApp (Pair x1 x2) (Pair y1 y2)
-
-instance TraversableB2 MyApp where
-  b2traverse :: Applicative e => (forall x y. f x y -> e (g x y)) -> MyApp f -> e (MyApp g)
-  b2traverse f MyApp {..} = MyApp <$> f helloBot' <*> f coinFlipBot'
+instance Semigroupal (->) These These (,) (Flip TextSerializer) where
+  combine :: (Flip TextSerializer x y, Flip TextSerializer x' y') -> Flip TextSerializer (These x x') (These y y')
+  combine (Flip (S.Serializer par1 pri1), Flip (S.Serializer par2 pri2)) =
+    Flip $
+      S.Serializer
+        { parser = uncurry can . (par1 &&& par2),
+          printer = these pri1 pri2 (\y y' -> pri1 y <> pri2 y')
+        }
 
 --------------------------------------------------------------------------------
 
+data HKD2 f = HKD2 {a :: f () Bool, b :: f () Text}
+
 helloBot :: Monad m => Bot m s () Text
 helloBot = undefined
 
-coinFlipBot :: Bot IO () () Bool
+coinFlipBot :: Monad m => Bot m s () Bool
 coinFlipBot = undefined
 
 -- | Packing the HKD with 'Bot' gives us the bot subroutinesf for our
 -- HKD.
-myAppBot :: Monad m => MyApp (Bot m s)
-myAppBot =
-  MyApp
-    { helloBot' = helloBot,
-      coinFlipBot' = undefined
-    }
-
-helloBotSerializer :: TextSerializer Text ()
-helloBotSerializer = undefined
-
-coinFlipSerializer :: TextSerializer Bool ()
-coinFlipSerializer = undefined
-
--- | Packing the HKD with 'Serializer' gives us serializers for the
--- 'Bot' subroutines of our HKD.
-myAppSerializer :: MyApp (Flip TextSerializer)
-myAppSerializer =
-  MyApp
-    { helloBot' = Flip helloBotSerializer,
-      coinFlipBot' = Flip coinFlipSerializer
+botHKD :: Monad m => HKD2 (Bot m s)
+botHKD =
+  HKD2
+    { a = coinFlipBot,
+      b = helloBot
     }
 
--- | Packing the HKD with 'Const2 Text' gives us labels for the 'Bot'
--- subroutines of our HKD. This could be constructed with GHC Generics
--- or Template Haskell.
-myAppNames :: MyApp (Const2 Text)
-myAppNames =
-  MyApp
-    { helloBot' = "Hello Bot",
-      coinFlipBot' = "Coin Flip Bot"
+serializerHKD :: HKD2 (Flip TextSerializer)
+serializerHKD =
+  HKD2
+    { a = Flip S.Serializer {parser = bool Nothing (Just ()) . (== "flip a coin"), printer = bool "tails" "heads"},
+      b = Flip S.Serializer {parser = bool Nothing (Just ()) . (== "cofree-bot"), printer = id}
     }
 
 --------------------------------------------------------------------------------
 
-instance Show (HKD2 In) where
-  show (HKD2 x y) = "(HKD2 " <> show x <> " " <> show y <> ")"
+newtype Compose2 f g a b = Compose2 (f (g a b))
+  deriving Functor
 
-instance Show (HKD2 Out) where
-  show (HKD2 x y) = "(HKD2 " <> show x <> " " <> show y <> ")"
+instance (Functor f, Bifunctor g) => Bifunctor (Compose2 f g) where
+  bimap :: Bifunctor g => (a -> b) -> (c -> d) -> Compose2 f g a c -> Compose2 f g b d
+  bimap f g (Compose2 fg) = Compose2 $ fmap (bimap f g) fg
 
-sequenceHKD2 :: Semigroupal (->) t1 t2 (,) p => HKD2 p -> p (t1 () ()) (t2 Bool Text)
-sequenceHKD2 (HKD2 a b) = combine (a, b)
+instance (Functor f, Profunctor g) => Profunctor (Compose2 f g) where
+  dimap :: (Functor f, Profunctor g) => (a -> b) -> (c -> d) -> Compose2 f g b c -> Compose2 f g a d
+  dimap f g (Compose2 fg) = Compose2 $ fmap (dimap f g) fg
 
-data HKD2 f = HKD2 {a :: f () Bool, b :: f () Text}
+type Optional :: ((k -> k -> Type) -> Type) -> (k -> k -> Type) -> Type
+newtype Optional hkd f = Optional (hkd (Compose2 Maybe f))
 
-instance Semigroupal (->) These These (,) (Flip TextSerializer) where
-  combine :: (Flip TextSerializer x y, Flip TextSerializer x' y') -> Flip TextSerializer (These x x') (These y y')
-  combine (Flip (S.Serializer par1 pri1), Flip (S.Serializer par2 pri2)) =
-    Flip $
-      S.Serializer
-        { parser = uncurry can . (par1 &&& par2),
-          printer = these pri1 pri2 (\y y' -> pri1 y <> pri2 y')
-        }
+class HKD p t i hkd where
+  type Fields hkd :: [(Type, Type)]
 
-type Optional :: ((k -> Type) -> Type) -> (k -> Type) -> Type
-newtype Optional hkd f = Optional (hkd (Compose Maybe f))
+  to :: hkd f `p` FoldMap t i f (Fields hkd)
+  from :: Profunctor f => FoldMap t i f (Fields hkd) `p` hkd f
 
 
-data In a b = In (Maybe a)
-  deriving (Show)
+instance HKD (->) (,) () HKD2 where
+  type Fields HKD2 = ['((), Bool), '((), Text)]
 
-data Out a b = Out (Maybe b)
-  deriving (Show)
-
-
-sequenceSerializer :: HKD2 (Flip TextSerializer) -> TextSerializer (HKD2 Out) (HKD2 In)
-sequenceSerializer (HKD2 x y) = f $ combine (x, y)
-  where
-    f :: Flip TextSerializer (These () ()) (These Bool Text) -> TextSerializer (HKD2 Out) (HKD2 In)
-    f (Flip (S.Serializer par pri)) =
-      S.Serializer
-        { parser = fmap (these (\() -> HKD2 (In (Just ())) (In Nothing)) (\() -> HKD2 (In Nothing) (In (Just ()))) (\() () -> HKD2 (In (Just ())) (In (Just ())))) . par,
-          printer = \case
-            (HKD2 (Out Nothing) (Out Nothing)) -> mempty
-            (HKD2 (Out (Just a)) (Out Nothing)) -> pri $ This a
-            (HKD2 (Out Nothing) (Out (Just b))) -> pri $ That b
-            (HKD2 (Out (Just a)) (Out (Just b))) -> pri $ These a b
-        }
-
-serializerHKD :: HKD2 (Flip TextSerializer)
-serializerHKD =
-  HKD2
-    { a = Flip S.Serializer {parser = bool Nothing (Just ()) . (== "flip a coin"), printer = bool "tails" "heads"},
-      b = Flip S.Serializer {parser = bool Nothing (Just ()) . (== "cofree-bot"), printer = id}
-    }
+  to :: HKD2 f -> FoldMap (,) () f (Fields HKD2)
+  to HKD2 {..} = Cons (a, Cons (b, Nil ()))
 
-serializer :: TextSerializer (HKD2 Out) (HKD2 In)
-serializer = sequenceSerializer serializerHKD
+  from :: FoldMap (,) () f (Fields HKD2) -> HKD2 f
+  from = \case
+    Cons (a, Cons (b, _)) -> HKD2 {..}
 
+instance HKD (->) (,) () hkd => HKD (Star Maybe) These Void (Optional hkd) where
+  type Fields (Optional hkd) = ['((), Bool), '((), Text)]
 
-data In1 a = In1 a
-data Out1 a = Out1 a
+  to :: HKD (->) (,) () hkd => Star Maybe (Optional hkd f) (FoldMap These Void f (Fields (Optional hkd)))
+  to = Star $ \(Optional hkd) -> _
 
---sequencer :: Semigroupal (->) (/+\) (/+\) (,) p => b p -> p (Optional b In) (Optional b Out)
---sequencer = undefined
+  from :: (Profunctor f, HKD (->) (,) () hkd) => Star Maybe (FoldMap These Void f (Fields (Optional hkd))) (Optional hkd f)
+  from = _ (sequenceFoldMapP @(Star Maybe) @These @Void @These @Void @These @Void)