Adds Monoidal Functor instances for Bot and ListT (#86)

* Adds Monoidal Functor instances

* Update nixpkgs

* Adds Monoidal Functor instances for ListT

* Use ListT Semigroupal instances in Bot

* Fix recursive case of `combine @(->) @These @(,) (ListT m)`

* Rewrite `/\` to operate on different inputs.

* Update monoidal-functors and matrix-client dependencies.

* Rewrite ListT monoidal-functors instances to use Deriving Via.

* Fix ListT Applicative and Alternative instances

* Adds hedghehog-classes tests

* Updates monoidal-functors pin in flake.nix

* Drop GHC8 from CI and update GHC9 versions in CI.

.github/workflows/cabal.yml

@@ -33,8 +33,8 @@ jobs:
 
     strategy:
       matrix:
-        cabal: ["3.6"]
-        ghc: ["8.10.7", "9.0.2", "9.2.4"]
+        cabal: ["3.10"]
+        ghc: ["9.2.8", "9.4.8", "9.6.3"]
 
     env:
       CONFIG: "--project-file=cabal.project"
@@ -44,15 +44,15 @@ jobs:
         uses: actions/checkout@v2
 
       - name: Setup
-        uses: haskell/actions/setup@v1
+        uses: haskell-actions/setup@v2
         id: setup-haskell-cabal
         with:
           ghc-version: ${{ matrix.ghc }}
           cabal-version: ${{ matrix.cabal }}
 
       - name: Freeze
         run: |
-          cabal configure --enable-tests --test-show-details=direct
+          cabal configure --enable-tests --test-show-details=direct $CONFIG
           cabal freeze
 
       - name: Cache

cabal.project

@@ -5,5 +5,10 @@ packages: cofree-bot
 source-repository-package
   type: git
   location: https://github.com/softwarefactory-project/matrix-client-haskell.git
-  tag: 0.1.4.2
-  subdir: matrix-client
+  tag: fb12649c8d8894dc19216301285c9888d0058c0f
+  subdir: matrix-client
+
+source-repository-package
+  type: git
+  location: https://github.com/solomon-b/monoidal-functors.git
+  tag: eeb61da953592b7c01ab319b14f961e8f04c82c0

chat-bots-contrib/src/Data/Chat/Server/Matrix.hs

@@ -11,7 +11,9 @@ where
 --------------------------------------------------------------------------------
 
 import Control.Lens
+import Control.Monad (zipWithM_)
 import Control.Monad.Except
+import Control.Monad.IO.Class (MonadIO (..))
 import Data.Chat.Bot
 import Data.Chat.Bot.Serialization
 import Data.Chat.Server
@@ -87,7 +89,7 @@ matrix session cache = Server $ do
           -- Do it again
           runServer $ go filterId (Just newSince)
 
-embedTextBot :: Applicative m => Bot m s Text Text -> Bot m s (RoomID, Event) (RoomID, Event)
+embedTextBot :: (Applicative m) => Bot m s Text Text -> Bot m s (RoomID, Event) (RoomID, Event)
 embedTextBot = second' . flip applySerializer eventSerializer
 
 eventSerializer :: Serializer Event Event Text Text

chat-bots-contrib/test/TestServer.hs

@@ -13,10 +13,10 @@ where
 
 import Control.Monad.Except
   ( MonadError (..),
-    MonadTrans (..),
     liftEither,
     runExceptT,
   )
+import Control.Monad.Trans (MonadTrans (..))
 import Data.Chat.Bot (Behavior, hoistBehavior)
 import Data.Chat.Server
   ( Env (..),
@@ -69,7 +69,7 @@ conformsToScript' behavior script = do
   fmap onlyLeft $ runExceptT $ bindFix $ annihilate server (hoistBehavior lift behavior)
   where
     -- TODO: move these somewhere else
-    bindFix :: Monad m => Fix m -> m Void
+    bindFix :: (Monad m) => Fix m -> m Void
     bindFix (Fix m) = m >>= bindFix
 
     onlyLeft :: Either a Void -> a

chat-bots/chat-bots.cabal

@@ -50,8 +50,10 @@ common common-libraries
     , base           >=2 && <5
     , bytestring
     , matrix-client
+    , monoidal-functors
     , network-uri
     , profunctors
+    , semialign
     , text
     , these
     , typed-process
@@ -91,3 +93,23 @@ library
     , random
     , transformers
     , vector
+
+--------------------------------------------------------------------------------
+
+test-suite chat-bot-tests
+  import:
+    , common-settings
+
+  type: exitcode-stdio-1.0
+  hs-source-dirs: test
+  main-is: Spec.hs
+
+  build-depends:
+    , base           >=2 && <5
+    , chat-bots
+    , hedgehog
+    , hedgehog-classes
+    , hspec
+    , hspec-core
+    , hspec-hedgehog
+    , text

chat-bots/src/Control/Monad/ListT.hs

@@ -1,7 +1,9 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Control.Monad.ListT
@@ -13,22 +15,33 @@ module Control.Monad.ListT
     emptyListT,
     consListT,
     singletonListT,
+    appendListT,
     joinListT,
     toListT,
     fromListT,
     hoistListT,
-    alignListT,
   )
 where
 
 --------------------------------------------------------------------------------
 
-import Control.Applicative (Alternative (..))
-import Control.Monad.Except (MonadError (..), MonadIO (..), MonadTrans (..), ap)
+import Control.Applicative (Alternative (..), Applicative (..))
+import Control.Monad (ap)
+#if MIN_VERSION_base(4,18,0)
+import Control.Monad.Except (MonadError (..))
+import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.Trans (MonadTrans (..))
+#else
+import Control.Monad.Except (MonadError (..), MonadIO (..), MonadTrans (..))
+#endif
+import Data.Align
 import Data.Bifunctor (Bifunctor (..))
 import Data.Foldable (Foldable (..))
 import Data.Functor ((<&>))
+import Data.Functor.Classes
+import Data.Functor.Monoidal qualified as Functor
 import Data.These (These (..))
+import Data.Void (Void)
 
 --------------------------------------------------------------------------------
 
@@ -40,45 +53,82 @@ newtype ListT m a = ListT
   { runListT :: m (ListF a (ListT m a))
   }
 
-instance Functor m => Functor (ListT m) where
-  fmap :: Functor m => (a -> b) -> ListT m a -> ListT m b
+instance (Eq1 m) => Eq1 (ListT m) where
+  liftEq f (ListT xs) (ListT ys) = liftEq g xs ys
+    where
+      g NilF NilF = True
+      g (ConsF x xs) (ConsF y ys) = f x y && liftEq f xs ys
+      g _ _ = False
+
+deriving instance (Eq (m (ListF a (ListT m a))), Eq1 m, Eq a) => Eq (ListT m a)
+
+deriving instance (Show (m (ListF a (ListT m a))), Show1 m, Show a) => Show (ListT m a)
+
+instance (Functor m) => Functor (ListT m) where
+  fmap :: (a -> b) -> ListT m a -> ListT m b
   fmap f (ListT ma) = ListT $ fmap (bimap f (fmap f)) $ ma
 
-instance Monad m => Applicative (ListT m) where
-  pure :: Monad m => a -> ListT m a
+instance (Monad m) => Applicative (ListT m) where
+  pure :: (Monad m) => a -> ListT m a
   pure = ListT . return . (`ConsF` emptyListT)
 
-  (<*>) :: Monad m => ListT m (a -> b) -> ListT m a -> ListT m b
+  (<*>) :: (Monad m) => ListT m (a -> b) -> ListT m a -> ListT m b
   (<*>) = ap
 
-instance Monad m => Alternative (ListT m) where
-  empty :: Monad m => ListT m a
-  empty = emptyListT
-
-  (<|>) :: Monad m => ListT m a -> ListT m a -> ListT m a
-  ListT m <|> ListT n = ListT $ do
-    x <- m
-    y <- n
-    pure $ case (x, y) of
-      (NilF, NilF) -> NilF
-      (ConsF x' xs, NilF) -> ConsF x' xs
-      (NilF, ConsF y' ys) -> ConsF y' ys
-      (ConsF x' xs, ConsF y' ys) ->
-        ConsF x' (ListT $ pure $ ConsF y' (xs <|> ys))
+instance (Monad m) => Alternative (ListT m) where
+  empty :: ListT m a
+  empty = nil
+
+  (<|>) :: ListT m a -> ListT m a -> ListT m a
+  xs <|> ys = appendListT xs ys
+
+instance (Applicative m) => Semialign (ListT m) where
+  align :: ListT m a -> ListT m b -> ListT m (These a b)
+  align (ListT m) (ListT n) =
+    ListT $
+      liftA2 (,) m n <&> \case
+        (NilF, NilF) -> NilF
+        (ConsF x' xs, NilF) -> ConsF (This x') (fmap This xs)
+        (NilF, ConsF y' ys) -> ConsF (That y') (fmap That ys)
+        (ConsF x' xs, ConsF y' ys) -> ConsF (These x' y') (align xs ys)
+
+instance (Applicative m) => Align (ListT m) where
+  nil :: ListT m a
+  nil = ListT $ pure NilF
+
+deriving via Functor.FromApplicative (ListT m) instance (Monad m) => Functor.Semigroupal (->) (,) (,) (ListT m)
+
+deriving via Functor.FromApplicative (ListT m) instance (Monad m) => Functor.Unital (->) () () (ListT m)
+
+deriving via Functor.FromAlternative (ListT m) instance (Monad m) => Functor.Semigroupal (->) Either (,) (ListT m)
+
+deriving via Functor.FromAlternative (ListT m) instance (Monad m) => Functor.Unital (->) Void () (ListT m)
+
+deriving via Functor.FromSemialign (ListT m) instance (Monad m) => Functor.Semigroupal (->) These (,) (ListT m)
+
+instance (Monad m) => Functor.Monoidal (->) (,) () (,) () (ListT m)
+
+instance (Monad m) => Functor.Monoidal (->) Either Void (,) () (ListT m)
+
+instance (Monad m) => Functor.Monoidal (->) These Void (,) () (ListT m)
+
+instance (Monad m) => Monad (ListT m) where
+  (>>=) :: ListT m a -> (a -> ListT m b) -> ListT m b
+  ma >>= amb = joinListT $ fmap amb ma
 
 instance MonadTrans ListT where
-  lift :: Monad m => m a -> ListT m a
+  lift :: (Monad m) => m a -> ListT m a
   lift ma = ListT $ fmap (\a -> ConsF a (ListT $ pure NilF)) ma
 
-instance MonadIO m => MonadIO (ListT m) where
-  liftIO :: MonadIO m => IO a -> ListT m a
+instance (MonadIO m) => MonadIO (ListT m) where
+  liftIO :: IO a -> ListT m a
   liftIO io = ListT $ liftIO $ fmap (\a -> ConsF a (ListT $ pure NilF)) io
 
-instance MonadError e m => MonadError e (ListT m) where
-  throwError :: MonadError e m => e -> ListT m a
+instance (MonadError e m) => MonadError e (ListT m) where
+  throwError :: e -> ListT m a
   throwError = lift . throwError
 
-  catchError :: MonadError e m => ListT m a -> (e -> ListT m a) -> ListT m a
+  catchError :: ListT m a -> (e -> ListT m a) -> ListT m a
   catchError m f = ListT . deepCatch . runListT $ m
     where
       deepCatch m' = fmap deepCatch' m' `catchError` \e -> runListT (f e)
@@ -87,15 +137,8 @@ instance MonadError e m => MonadError e (ListT m) where
         NilF -> NilF
         ConsF a r -> ConsF a (ListT $ deepCatch $ runListT r)
 
-instance Monad m => Monad (ListT m) where
-  return :: Monad m => a -> ListT m a
-  return = pure
-
-  (>>=) :: Monad m => ListT m a -> (a -> ListT m b) -> ListT m b
-  ma >>= amb = joinListT $ fmap amb ma
-
 data ListF a r = NilF | ConsF a r
-  deriving (Functor)
+  deriving (Show, Eq, Functor)
 
 instance Bifunctor ListF where
   bimap :: (a -> b) -> (c -> d) -> ListF a c -> ListF b d
@@ -106,35 +149,44 @@ instance Bifunctor ListF where
 --------------------------------------------------------------------------------
 
 -- | The empty 'ListT'.
-emptyListT :: Applicative m => ListT m a
-emptyListT = ListT $ pure NilF
+emptyListT :: (Applicative m) => ListT m a
+emptyListT = nil
 
 -- | A 'ListT' of one element.
-singletonListT :: Applicative m => a -> ListT m a
+singletonListT :: (Applicative m) => a -> ListT m a
 singletonListT a = consListT a emptyListT
 
 -- | Consing a value to a 'LisT'.
-consListT :: Applicative m => a -> ListT m a -> ListT m a
+consListT :: (Applicative m) => a -> ListT m a -> ListT m a
 consListT a = \case
   ListT ml ->
     ListT $
       ml <&> \case
         NilF -> ConsF a emptyListT
         ConsF x xs -> ConsF a $ ListT $ pure $ ConsF x xs
 
+appendListT :: (Monad m) => ListT m a -> ListT m a -> ListT m a
+appendListT (ListT xs) ys = ListT $ do
+  xs' <- xs
+  runListT $ appendListF xs' ys
+
+appendListF :: (Monad m) => ListF a (ListT m a) -> ListT m a -> ListT m a
+appendListF NilF ys = ys
+appendListF (ConsF x xs) ys = ListT $ pure $ ConsF x $ appendListT xs ys
+
 -- | Convert some 'Foldable' @t@ into a 'ListT'.
 toListT :: (Foldable t, Applicative m) => t a -> ListT m a
 toListT = foldr' consListT emptyListT
 
 -- | Convert a 'ListT' into a '[]' and sequence the effects.
-fromListT :: Monad m => ListT m a -> m [a]
+fromListT :: (Monad m) => ListT m a -> m [a]
 fromListT (ListT m) =
   m >>= \case
     NilF -> pure []
     ConsF a xs -> fmap (a :) $ fromListT xs
 
 -- | The join operation of the 'ListT' @m@ monad.
-joinListT :: Monad m => ListT m (ListT m a) -> ListT m a
+joinListT :: (Monad m) => ListT m (ListT m a) -> ListT m a
 joinListT (ListT ma) = ListT $ do
   fma <- ma
   case fma of
@@ -147,16 +199,5 @@ joinListT (ListT ma) = ListT $ do
 
 -- | Lift a monad morphism from @m@ to @n@ into a monad morphism from
 -- @ListT m@ to @ListT n@.
-hoistListT :: Functor n => (forall x. m x -> n x) -> ListT m a -> ListT n a
+hoistListT :: (Functor n) => (forall x. m x -> n x) -> ListT m a -> ListT n a
 hoistListT f = ListT . fmap (fmap (hoistListT f)) . f . runListT
-
--- | Align two 'ListT's, interleaving their effects.
-alignListT :: Monad m => ListT m a -> ListT m b -> ListT m (These a b)
-alignListT (ListT m) (ListT n) = ListT $ do
-  x <- m
-  y <- n
-  pure $ case (x, y) of
-    (NilF, NilF) -> NilF
-    (ConsF x' xs, NilF) -> ConsF (This x') (fmap This xs)
-    (NilF, ConsF y' ys) -> ConsF (That y') (fmap That ys)
-    (ConsF x' xs, ConsF y' ys) -> ConsF (These x' y') (alignListT xs ys)