Adds Monoidal Functor instances

chat-bots/chat-bots.cabal

@@ -50,6 +50,7 @@ common common-libraries
     , base           >=2 && <5
     , bytestring
     , matrix-client
+    , monoidal-functors
     , network-uri
     , profunctors
     , text

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

@@ -1,7 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ViewPatterns #-}
 
 -- | The core Chat Bot encoding.
 module Data.Chat.Bot
@@ -34,21 +34,25 @@ where
 --------------------------------------------------------------------------------
 
 import Control.Monad.Except (MonadIO (..), MonadTrans (..))
-import Control.Monad.ListT (ListF (..), ListT (..), emptyListT, hoistListT)
+import Control.Monad.ListT (ListF (..), ListT (..), alignListT, emptyListT, hoistListT)
 import Control.Monad.Reader (MonadReader, ReaderT (..))
 import Control.Monad.State (MonadState, StateT (..))
 import Data.Bifunctor (Bifunctor (..))
+import Data.Bifunctor.Monoidal qualified as Bifunctor
 import Data.Chat.Utils (readFileMaybe)
 #if __GLASGOW_HASKELL__ >= 902
-import Control.Applicative (asum)
+import Control.Applicative (asum, liftA2)
 #else
-import Data.Foldable (asum)
+import Data.Foldable (asum, liftA2)
 #endif
 import Data.Functor ((<&>))
 import Data.Kind
 import Data.Profunctor (Choice (..), Profunctor (..), Strong (..))
 import Data.Profunctor.Traversing (Traversing (..))
 import Data.Text qualified as Text
+import Data.These (These (..))
+import Data.Trifunctor.Monoidal qualified as Trifunctor
+import Data.Void (Void, absurd)
 import System.Directory (createDirectoryIfMissing)
 import System.FilePath ((</>))
 
@@ -83,6 +87,42 @@ newtype Bot m s i o = Bot {runBot :: s -> i -> ListT m (o, s)}
     (Functor, Applicative, Monad, MonadState s, MonadReader i, MonadIO)
     via StateT s (ReaderT i (ListT m))
 
+instance Monad m => Trifunctor.Semigroupal (->) (,) (,) (,) (,) (Bot m) where
+  combine :: (Bot m s i o, Bot m t i' o') -> Bot m (s, t) (i, i') (o, o')
+  combine (Bot b1, Bot b2) = Bot $ \(s, t) (i, i') ->
+    liftA2 (curry (\((o, s'), (o', t')) -> ((o, o'), (s', t')))) (b1 s i) (b2 t i')
+
+instance Functor m => Trifunctor.Semigroupal (->) (,) Either Either (,) (Bot m) where
+  combine :: (Bot m s i o, Bot m t i' o') -> Bot m (s, t) (Either i i') (Either o o')
+  combine (Bot m1, Bot m2) = Bot $ \(s, t) -> \case
+    Left i -> (bimap Left (,t) <$> m1 s i)
+    Right i' -> bimap Right (s,) <$> m2 t i'
+
+instance Monad m => Trifunctor.Semigroupal (->) (,) These These (,) (Bot m) where
+  combine :: (Bot m s i o, Bot m t i' o') -> Bot m (s, t) (These i i') (These o o')
+  combine (Bot b1, Bot b2) = Bot $ \(s, t) -> \case
+    This i -> bimap This (,t) <$> b1 s i
+    That i' -> bimap That (s,) <$> b2 t i'
+    These i i' -> do
+      alignListT (b1 s i) (b2 t i') <&> \case
+        This (o, s) -> (This o, (s, t))
+        That (o', t) -> (That o', (s, t))
+        These (o, s) (o', t) -> (These o o', (s, t))
+
+instance (Monad m) => Trifunctor.Unital (->) () () () () (Bot m) where
+  introduce :: () -> Bot m () () ()
+  introduce () = Bot $ \() () -> pure ((), ())
+
+instance Trifunctor.Unital (->) () Void Void () (Bot m) where
+  introduce :: () -> Bot m () Void Void
+  introduce () = Bot $ \() -> absurd
+
+instance (Monad m) => Trifunctor.Monoidal (->) (,) () (,) () (,) () (,) () (Bot m)
+
+instance (Applicative m) => Trifunctor.Monoidal (->) (,) () Either Void Either Void (,) () (Bot m)
+
+instance (Monad m) => Trifunctor.Monoidal (->) (,) () These Void These Void (,) () (Bot m)
+
 instance Functor f => Profunctor (Bot f s) where
   dimap :: Functor f => (a -> b) -> (c -> d) -> Bot f s b c -> Bot f s a d
   dimap f g (Bot bot) = do
@@ -176,6 +216,17 @@ instance Functor m => Profunctor (Behavior m) where
   dimap :: Functor m => (a -> b) -> (c -> d) -> Behavior m b c -> Behavior m a d
   dimap f g (Behavior b) = Behavior $ dimap f (fmap (bimap g (dimap f g))) b
 
+instance (Monad m) => Bifunctor.Semigroupal (->) (,) (,) (,) (Behavior m) where
+  combine :: (Behavior m i o, Behavior m i' o') -> Behavior m (i, i') (o, o')
+  combine (Behavior m1, Behavior m2) = Behavior $ \(i, i') -> do
+    liftA2 (uncurry (\o m1' (o', m2') -> ((o, o'), Bifunctor.combine (m1', m2')))) (m1 i) (m2 i')
+
+instance (Monad m) => Bifunctor.Unital (->) () () () (Behavior m) where
+  introduce :: () -> Behavior m () ()
+  introduce () = Behavior $ \() -> pure ((), Bifunctor.introduce ())
+
+instance (Monad m) => Bifunctor.Monoidal (->) (,) () (,) () (,) () (Behavior m)
+
 instance Monad m => Choice (Behavior m) where
   left' :: Monad m => Behavior m a b -> Behavior m (Either a c) (Either b c)
   left' (Behavior b) =

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

@@ -15,12 +15,12 @@ where
 --------------------------------------------------------------------------------
 
 import Control.Monad.ListT (alignListT, toListT)
-import Data.Bifunctor (Bifunctor (..))
-import Data.Chat.Bot (Bot (..))
+import Data.Bifunctor.Monoidal.Specialized (split')
+import Data.Chat.Bot (Bot (..), invmapBot)
 import Data.Chat.Utils (type (/+\), type (/\), type (\*/), type (\/))
-import Data.Functor ((<&>))
-import Data.Profunctor (Strong (..))
+import Data.Profunctor (Profunctor (..), Strong (..))
 import Data.These (These (..))
+import Data.Trifunctor.Monoidal qualified as Trifunctor
 
 --------------------------------------------------------------------------------
 
@@ -57,24 +57,14 @@ nudgeRight = nudge . Right
 infixr 9 /\
 
 (/\) :: Monad m => Bot m s i o -> Bot m s' i o' -> Bot m (s /\ s') i (o /\ o')
-(/\) (Bot b1) (Bot b2) = Bot $ \(s, s') i -> do
-  (nextState, responses) <- b1 s i
-  (nextState', responses') <- b2 s' i
-  pure $ (,) (nextState, nextState') (responses, responses')
+(/\) b1 = lmap split' . curry Trifunctor.combine b1
 
 -- | Runs two bots and then interleaves their output.
 infixr 9 /+\
 
 (/+\) ::
   Monad m => Bot m s i o -> Bot m s' i' o' -> Bot m (s /\ s') (i /+\ i') (o /+\ o')
-(/+\) (Bot b1) (Bot b2) = Bot $ \(s, s') -> \case
-  This i -> fmap (bimap This (,s')) $ b1 s i
-  That i' -> fmap (bimap That (s,)) $ b2 s' i'
-  These i i' ->
-    alignListT (b1 s i) (b2 s' i') <&> \case
-      This (o, _s) -> (This o, (s, s'))
-      That (o', _s') -> (That o', (s, s'))
-      These (o, s) (o', s') -> (These o o', (s, s'))
+(/+\) b1 b2 = Trifunctor.combine (b1, b2)
 
 -- | Runs two bots on the same input and then interleaves their
 -- output, sequencing if they both return an output for the same
@@ -97,5 +87,4 @@ infixr 9 /.\
 infixr 9 \/
 
 (\/) :: Monad m => Bot m s i o -> Bot m s i' o' -> Bot m s (i \/ i') (o \/ o')
-(\/) (Bot b1) (Bot b2) =
-  Bot $ \s -> either (fmap (first Left) . b1 s) (fmap (first Right) . b2 s)
+(\/) b1 b2 = invmapBot fst split' $ Trifunctor.combine (b1, b2)