Higher Kinded Bots

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
+  subdir: matrix-client
+
+source-repository-package
+  type: git
+  location: https://github.com/solomon-b/monoidal-functors.git
+  tag: a9770c92902a75974e52d036381437d6f9631c19

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,11 @@ 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
     Data.Chat.Bot.Context
@@ -85,6 +91,7 @@ library
     , http-client
     , lens
     , monad-loops
+    , monoidal-functors
     , mtl
     , pretty-simple
     , process

chat-bots/src/Data/Align2.hs

@@ -0,0 +1,32 @@
+module Data.Align2
+  ( Semialign2 (..),
+  )
+where
+
+--------------------------------------------------------------------------------
+
+import Data.Bifunctor
+import Data.These (These (..))
+
+--------------------------------------------------------------------------------
+
+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)

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 (Show, 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/Bifunctor/HKD.hs

@@ -0,0 +1,52 @@
+{-# 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}
+  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
+  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

chat-bots/src/Data/Chat/Bot/Serialization.hs

@@ -7,11 +7,13 @@ 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
+-- import Data.Bifunctor.Monoidal (Semigroupal (..))
 
 --------------------------------------------------------------------------------
 
@@ -30,6 +32,23 @@ 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
+      }
+
+-- 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

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
+(...) = (.) . (.)

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

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

@@ -0,0 +1,118 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Data.Trifunctor.Barbie where
+
+-- ( First (..),
+--   Second (..),
+--   Optional (..),
+--   traverseThese,
+--   zipMyApp,
+-- )
+
+--------------------------------------------------------------------------------
+
+import Data.Bifunctor.Monoidal
+import Data.Bifunctor.Monoidal.Specialized
+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 (can)
+import Data.Kind (Type)
+import Data.Text (Text)
+import Data.These
+import Data.Bifunctor.HKD
+import Data.Void
+import Data.Profunctor
+import Data.Bifunctor
+
+--------------------------------------------------------------------------------
+
+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)
+
+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 :: Monad m => Bot m s () Bool
+coinFlipBot = undefined
+
+-- | Packing the HKD with 'Bot' gives us the bot subroutinesf for our
+-- HKD.
+botHKD :: Monad m => HKD2 (Bot m s)
+botHKD =
+  HKD2
+    { a = coinFlipBot,
+      b = helloBot
+    }
+
+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}
+    }
+
+--------------------------------------------------------------------------------
+
+newtype Compose2 f g a b = Compose2 (f (g a b))
+  deriving Functor
+
+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
+
+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
+
+type Optional :: ((k -> k -> Type) -> Type) -> (k -> k -> Type) -> Type
+newtype Optional hkd f = Optional (hkd (Compose2 Maybe f))
+
+class HKD p t i hkd where
+  type Fields hkd :: [(Type, Type)]
+
+  to :: hkd f `p` FoldMap t i f (Fields hkd)
+  from :: Profunctor f => FoldMap t i f (Fields hkd) `p` hkd f
+
+
+instance HKD (->) (,) () HKD2 where
+  type Fields HKD2 = ['((), Bool), '((), Text)]
+
+  to :: HKD2 f -> FoldMap (,) () f (Fields HKD2)
+  to HKD2 {..} = Cons (a, Cons (b, Nil ()))
+
+  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)]
+
+  to :: HKD (->) (,) () hkd => Star Maybe (Optional hkd f) (FoldMap These Void f (Fields (Optional hkd)))
+  to = Star $ \(Optional hkd) -> _
+
+  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)