y

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/src/Data/Bifunctor/HKD.hs

@@ -36,8 +36,10 @@ data FoldMap t i f xs where
   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

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

@@ -13,6 +13,7 @@ import Data.Chat.Utils (can, type (/+\))
 import Data.Text (Text)
 import Data.These (These (..), these)
 import Data.Profunctor
+-- import Data.Bifunctor.Monoidal (Semigroupal (..))
 
 --------------------------------------------------------------------------------
 
@@ -40,6 +41,15 @@ instance Profunctor (Serializer so si) where
         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/Trifunctor/Barbie.hs

@@ -1,8 +1,9 @@
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Data.Trifunctor.Barbie where
 
@@ -15,62 +16,20 @@ module Data.Trifunctor.Barbie where
 
 --------------------------------------------------------------------------------
 
-import Control.Applicative
-import Control.Category.Cartesian
-import Data.Align2
-import Data.Bifoldable
-import Data.Bifunctor.Const2 (Const2 (..))
 import Data.Bifunctor.Monoidal
 import Data.Bifunctor.Monoidal.Specialized
-import Data.Bifunctor.Product (Product (..))
-import Data.Bitraversable
 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 (type (/+\), can)
+import Data.Chat.Utils (can)
 import Data.Kind (Type)
-import Data.Profunctor (Profunctor (..))
 import Data.Text (Text)
 import Data.These
-import Data.Functor.Compose
-import Data.Functor.Identity
-
---------------------------------------------------------------------------------
-
-class FunctorB2 (b :: (k -> k' -> Type) -> Type) where
-  b2map :: (forall x y. f x y -> g x y) -> b f -> b g
-
-class FunctorB2 b => ApplicativeB2 (b :: (Type -> Type -> Type) -> Type) where
-  b2pure :: Profunctor f => (forall x y. f x y) -> b f
-  b2prod :: b f -> b g -> b (f `Product` g)
-
-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)
-
---------------------------------------------------------------------------------
-
-newtype First a b = First (Maybe a)
-
-newtype Second a b = Second (Maybe b)
-
-newtype Both p a b = Both (Maybe (p a b))
-
---------------------------------------------------------------------------------
-
--- TODO: Replace @align2'@ with @Semialign2@ instance.
-traverseThese ::
-  ( Profunctor p,
-    Semialign2 p,
-    Applicative (p (MyApp First))
-  ) =>
-  (forall a b c d. p a b -> p c d -> p (a /+\ c) (b /+\ d)) ->
-  MyApp p ->
-  p (MyApp First) (MyApp Second)
-traverseThese align2' barbie = b2traverse undefined barbie
-
-b2ZipWith :: ApplicativeB2 barbie => (forall x y. p x y -> q x y -> pq x y) -> barbie p -> barbie q -> barbie pq
-b2ZipWith f bp bq = b2map (\(Pair fa ga) -> f fa ga) (bp `b2prod` bq)
+import Data.Bifunctor.HKD
+import Data.Void
+import Data.Profunctor
+import Data.Bifunctor
 
 --------------------------------------------------------------------------------
 
@@ -81,132 +40,79 @@ instance Semigroupal (->) (,) (,) (,) f => Semigroupal (->) (,) (,) (,) (Flip f)
   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)
 
---------------------------------------------------------------------------------
--- HKD Bot Proof of Concept
-
--- TODO: Add a state param
-data MyApp p = MyApp
-  { helloBot' :: p () Text,
-    coinFlipBot' :: p () Bool
-  }
-
-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'}
-
-instance ApplicativeB2 MyApp where
-  b2pure :: Profunctor f => (forall x y. f x y) -> MyApp f
-  b2pure fxy = MyApp fxy fxy
-
-  b2prod :: MyApp f -> MyApp g -> MyApp (Product f g)
-  b2prod (MyApp x1 y1) (MyApp x2 y2) = MyApp (Pair x1 x2) (Pair y1 y2)
-
-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'
+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 :: Bot IO () () Bool
+coinFlipBot :: Monad m => Bot m s () Bool
 coinFlipBot = undefined
 
 -- | Packing the HKD with 'Bot' gives us the bot subroutinesf for our
 -- HKD.
-myAppBot :: Monad m => MyApp (Bot m s)
-myAppBot =
-  MyApp
-    { helloBot' = helloBot,
-      coinFlipBot' = undefined
-    }
-
-helloBotSerializer :: TextSerializer Text ()
-helloBotSerializer = undefined
-
-coinFlipSerializer :: TextSerializer Bool ()
-coinFlipSerializer = undefined
-
--- | Packing the HKD with 'Serializer' gives us serializers for the
--- 'Bot' subroutines of our HKD.
-myAppSerializer :: MyApp (Flip TextSerializer)
-myAppSerializer =
-  MyApp
-    { helloBot' = Flip helloBotSerializer,
-      coinFlipBot' = Flip coinFlipSerializer
+botHKD :: Monad m => HKD2 (Bot m s)
+botHKD =
+  HKD2
+    { a = coinFlipBot,
+      b = helloBot
     }
 
--- | 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"
+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}
     }
 
 --------------------------------------------------------------------------------
 
-instance Show (HKD2 In) where
-  show (HKD2 x y) = "(HKD2 " <> show x <> " " <> show y <> ")"
+newtype Compose2 f g a b = Compose2 (f (g a b))
+  deriving Functor
 
-instance Show (HKD2 Out) where
-  show (HKD2 x y) = "(HKD2 " <> show x <> " " <> show y <> ")"
+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
 
-sequenceHKD2 :: Semigroupal (->) t1 t2 (,) p => HKD2 p -> p (t1 () ()) (t2 Bool Text)
-sequenceHKD2 (HKD2 a b) = combine (a, b)
+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
 
-data HKD2 f = HKD2 {a :: f () Bool, b :: f () Text}
+type Optional :: ((k -> k -> Type) -> Type) -> (k -> k -> Type) -> Type
+newtype Optional hkd f = Optional (hkd (Compose2 Maybe 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 (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')
-        }
+class HKD p t i hkd where
+  type Fields hkd :: [(Type, Type)]
 
-type Optional :: ((k -> Type) -> Type) -> (k -> Type) -> Type
-newtype Optional hkd f = Optional (hkd (Compose Maybe f))
+  to :: hkd f `p` FoldMap t i f (Fields hkd)
+  from :: Profunctor f => FoldMap t i f (Fields hkd) `p` hkd f
 
 
-data In a b = In (Maybe a)
-  deriving (Show)
+instance HKD (->) (,) () HKD2 where
+  type Fields HKD2 = ['((), Bool), '((), Text)]
 
-data Out a b = Out (Maybe b)
-  deriving (Show)
-
-
-sequenceSerializer :: HKD2 (Flip TextSerializer) -> TextSerializer (HKD2 Out) (HKD2 In)
-sequenceSerializer (HKD2 x y) = f $ combine (x, y)
-  where
-    f :: Flip TextSerializer (These () ()) (These Bool Text) -> TextSerializer (HKD2 Out) (HKD2 In)
-    f (Flip (S.Serializer par pri)) =
-      S.Serializer
-        { parser = fmap (these (\() -> HKD2 (In (Just ())) (In Nothing)) (\() -> HKD2 (In Nothing) (In (Just ()))) (\() () -> HKD2 (In (Just ())) (In (Just ())))) . par,
-          printer = \case
-            (HKD2 (Out Nothing) (Out Nothing)) -> mempty
-            (HKD2 (Out (Just a)) (Out Nothing)) -> pri $ This a
-            (HKD2 (Out Nothing) (Out (Just b))) -> pri $ That b
-            (HKD2 (Out (Just a)) (Out (Just b))) -> pri $ These a b
-        }
-
-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}
-    }
+  to :: HKD2 f -> FoldMap (,) () f (Fields HKD2)
+  to HKD2 {..} = Cons (a, Cons (b, Nil ()))
 
-serializer :: TextSerializer (HKD2 Out) (HKD2 In)
-serializer = sequenceSerializer serializerHKD
+  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)]
 
-data In1 a = In1 a
-data Out1 a = Out1 a
+  to :: HKD (->) (,) () hkd => Star Maybe (Optional hkd f) (FoldMap These Void f (Fields (Optional hkd)))
+  to = Star $ \(Optional hkd) -> _
 
---sequencer :: Semigroupal (->) (/+\) (/+\) (,) p => b p -> p (Optional b In) (Optional b Out)
---sequencer = undefined
+  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)