HKD Proof of Concept

chat-bots/chat-bots.cabal

@@ -65,6 +65,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

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

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)

chat-bots/src/Data/Trifunctor/Barbie.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE RankNTypes #-}
+
+module Data.Trifunctor.Barbie where
+
+-- ( First (..),
+--   Second (..),
+--   Optional (..),
+--   traverseThese,
+--   zipMyApp,
+-- )
+
+--------------------------------------------------------------------------------
+
+import Data.Bifunctor.Const2 (Const2 (..))
+import Data.Chat.Bot (Bot)
+import Data.Chat.Serialization qualified as S
+import Data.Chat.Utils (type (/+\))
+import Data.Text (Text)
+import Data.Chat.Serialization (TextSerializer)
+
+--------------------------------------------------------------------------------
+
+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: These should be generically derivable in the same way as
+-- their Functor equivalents are derived in barbies.
+
+traverseThese :: (p a b -> p c d -> p (a /+\ c) (b /+\ d)) -> barbie p -> p (barbie First) (barbie Second)
+traverseThese _align2 _myApp = undefined
+
+zipMyApp :: (forall x y. p x y -> q x y -> pq x y) -> barbie p -> barbie q -> barbie pq
+zipMyApp _ = undefined
+
+--------------------------------------------------------------------------------
+
+-- | 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' = zipMyApp (\(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
+    }