From 817497eb67305fc6ecb61c208f9a393b86f03ae0 Mon Sep 17 00:00:00 2001
From: solomon <ssbothwell@gmail.com>
Date: Fri, 9 Dec 2022 13:14:11 -0800
Subject: [PATCH] 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 | 142 ++++++++++++++++++++++++
 4 files changed, 187 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 9b8c5df..dca7d9b 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.Sessions
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..7cae701
--- /dev/null
+++ b/chat-bots/src/Data/Trifunctor/Barbie.hs
@@ -0,0 +1,142 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Data.Trifunctor.Barbie where
+
+-- ( First (..),
+--   Second (..),
+--   Optional (..),
+--   traverseThese,
+--   zipMyApp,
+-- )
+
+--------------------------------------------------------------------------------
+
+import Data.Bifunctor (Bifunctor (..))
+import Data.Bifunctor.Const2 (Const2 (..))
+import Data.Bifunctor.Product
+import Data.Chat.Bot (Bot)
+import Data.Chat.Serialization (TextSerializer)
+import Data.Chat.Serialization qualified as S
+import Data.Chat.Utils
+import Data.Kind (Type)
+import Data.Text (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 :: Bifunctor f => (forall x y. f x y) -> b f
+  b2prod :: b f -> b g -> b (f `Product` g)
+
+instance ApplicativeB2 MyApp where
+  b2pure :: Bifunctor f => (forall x y. f x y) -> MyApp f
+  b2pure fxy = MyApp (second (const ()) fxy) (first (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 ::
+  (p a b -> p c d -> p (a /+\ c) (b /+\ d)) ->
+  barbie p ->
+  p (barbie First) (barbie Second)
+traverseThese align2' barbie = undefined
+
+bbZipWith :: ApplicativeB2 barbie => (forall x y. p x y -> q x y -> pq x y) -> barbie p -> barbie q -> barbie pq
+bbZipWith 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' = undefined,
+      coinFlipBot' = undefined
+    }
+
+-- | 'Serializer' subroutine of 'MyApp' augmented with label prefixes
+-- for each subroutine.
+myAppSerializer' :: MyApp TextSerializer
+myAppSerializer' = bbZipWith (\(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 = traverseThese (S./+\) myAppSerializer'
+
+-- | 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
+    }