Merge pull request #63 from cofree-coffee/feature/parsing

Bot I/O Serialization

Makefile

@@ -110,4 +110,4 @@ clean: $(GENERATED_CABAL_FILES)
 ## test-no-backends
 # the leftover tests with no particular backend, like Remote Schemas
 test: 
-	cabal run chat-bots-contrib-test
+	cabal test all

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

@@ -1,7 +1,13 @@
 module Data.Chat.Bot.Calculator
-  ( calculatorBot,
-    simplifyCalculatorBot,
-    printCalcOutput,
+  ( -- * Bot
+    calculatorBot,
+    calculatorBot',
+    printer,
+
+    -- * Serializer
+    calculatorSerializer,
+
+    -- * Language
     module Language,
   )
 where
@@ -10,38 +16,33 @@ where
 
 import Control.Monad.Reader
 import Control.Monad.State
+import Data.Attoparsec.Text (parseOnly)
 import Data.Chat.Bot
 import Data.Chat.Bot.Calculator.Language as Language
-import Data.Chat.Bot.Monoidal
+import Data.Chat.Bot.Serialization (TextSerializer)
+import Data.Chat.Bot.Serialization qualified as S
 import Data.Chat.Utils
-import Data.Profunctor
 import Data.Text (Text)
 import Data.Text qualified as Text
 
 --------------------------------------------------------------------------------
 
 calculatorBot :: Bot IO CalcState Statement (CalcError \/ CalcResp)
-calculatorBot = do
-  statement <- ask
-  state $ execCalculator statement
-
-parseErrorBot :: Monad m => Bot m s ParseError Text
-parseErrorBot = pureStatelessBot $ \ParseError {..} ->
-  "Failed to parse msg: \""
-    <> parseInput
-    <> "\". Error message was: \""
-    <> parseError
-    <> "\"."
-
-simplifyCalculatorBot ::
-  Monad m =>
-  Bot m s Statement (CalcError \/ CalcResp) ->
-  Bot m s Text Text
-simplifyCalculatorBot bot =
-  dimap parseStatement indistinct $ parseErrorBot \/ rmap printCalcOutput bot
-
-printCalcOutput :: Either CalcError CalcResp -> Text
-printCalcOutput = \case
+calculatorBot = ask >>= state . execCalculator
+
+calculatorBot' :: Bot IO CalcState Text Text
+calculatorBot' = S.applySerializer calculatorBot calculatorSerializer
+
+--------------------------------------------------------------------------------
+
+calculatorSerializer :: TextSerializer (CalcError \/ CalcResp) Statement
+calculatorSerializer = S.Serializer {parser, printer}
+
+parser :: Text -> Maybe Statement
+parser = either (const Nothing) Just . parseOnly statementP
+
+printer :: Either CalcError CalcResp -> Text
+printer = \case
   Left err -> Text.pack $ show err
   Right Ack -> "*variable saved*"
   Right (Log e n) -> Text.pack $ show e <> " = " <> show n

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

@@ -1,37 +1,34 @@
-module Data.Chat.Bot.CoinFlip where
+module Data.Chat.Bot.CoinFlip
+  ( -- * Bot
+    coinFlipBot,
+
+    -- * Serializer
+    coinFlipSerializer,
+  )
+where
 
 --------------------------------------------------------------------------------
 
-import Control.Monad.ListT (emptyListT)
-import Control.Monad.Reader
 import Data.Attoparsec.Text
-import Data.Bifunctor (bimap)
-import Data.Chat.Bot
-import Data.Profunctor
+import Data.Chat.Bot (Bot)
+import Data.Chat.Bot.Serialization (TextSerializer)
+import Data.Chat.Bot.Serialization qualified as S
 import Data.Text (Text)
 import Data.Text qualified as Text
 import System.Random (randomIO)
 
 --------------------------------------------------------------------------------
 
 coinFlipBot :: Bot IO () () Bool
-coinFlipBot = do
-  randomIO
-
-simplifyCoinFlipBot :: forall s. Bot IO s () Bool -> Bot IO s Text Text
-simplifyCoinFlipBot b = do
-  t <- ask
-  case to t of
-    Left _err -> Bot $ pure $ const emptyListT
-    Right _ -> dimap (const ()) from $ b
-  where
-    to :: Text -> Either Text ()
-    to = fmap (bimap Text.pack id) $ parseOnly parseCoinFlipCommand
-
-    from :: Bool -> Text
-    from = \case
-      True -> "Coin Flip Result: True"
-      False -> "Coin Flip Result: False"
-
-parseCoinFlipCommand :: Parser ()
-parseCoinFlipCommand = "flip a coin" *> pure ()
+coinFlipBot = randomIO
+
+--------------------------------------------------------------------------------
+
+coinFlipSerializer :: TextSerializer Bool ()
+coinFlipSerializer = S.Serializer {parser, printer}
+
+parser :: Text -> Maybe ()
+parser = either (const Nothing) Just . parseOnly ("flip a coin" *> pure ())
+
+printer :: Bool -> Text
+printer x = "Coin Flip Result: " <> Text.pack (show x)

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

@@ -1,9 +1,13 @@
 {-# LANGUAGE NumDecimals #-}
 
 module Data.Chat.Bot.GHCI
-  ( ghciBot,
+  ( -- * Bot
+    ghciBot,
     ghciConfig,
     hGetOutput,
+
+    -- * Serializer
+    ghciSerializer,
   )
 where
 
@@ -12,11 +16,9 @@ where
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Loops (whileM)
-import Data.Attoparsec.Text as A
 import Data.Chat.Bot
-import Data.Chat.Bot.Monoidal
-import Data.Chat.Utils
-import Data.Profunctor
+import Data.Chat.Bot.Serialization (TextSerializer)
+import Data.Chat.Bot.Serialization qualified as S
 import Data.Text (Text)
 import Data.Text qualified as Text
 import GHC.Conc (threadDelay)
@@ -25,35 +27,29 @@ import System.Process.Typed
 
 --------------------------------------------------------------------------------
 
-hGetOutput :: Handle -> IO String
-hGetOutput handle = whileM (hReady handle) (hGetChar handle)
+ghciBot :: Process Handle Handle () -> Bot IO () Text Text
+ghciBot p = Bot $
+  \s i -> do
+    o <- liftIO $ do
+      hPutStrLn (getStdin p) $ Text.unpack i
+      hFlush (getStdin p)
+      void $ threadDelay 5e5
+      hGetOutput (getStdout p)
+    pure (Text.pack o, s)
 
-ghciBot' :: Process Handle Handle () -> Bot IO () Text Text
-ghciBot' p =
-  contramapMaybeBot (either (const Nothing) Just . parseOnly ghciInputParser) $
-    Bot $
-      \s i -> do
-        o <- liftIO $ do
-          hPutStrLn (getStdin p) $ Text.unpack i
-          hFlush (getStdin p)
-          void $ threadDelay 5e5
-          hGetOutput (getStdout p)
-        pure (Text.pack o, s)
+--------------------------------------------------------------------------------
 
-ghciBot :: Process Handle Handle () -> Bot IO () Text Text
-ghciBot p =
-  dimap (distinguish (/= "ghci: :q")) indistinct $
-    pureStatelessBot (const $ "I'm Sorry Dave")
-      \/ ghciBot' p
+ghciSerializer :: TextSerializer Text Text
+ghciSerializer = S.prefix "ghci" S.Serializer {parser = pure, printer = id}
+
+--------------------------------------------------------------------------------
+
+hGetOutput :: Handle -> IO String
+hGetOutput handle = whileM (hReady handle) (hGetChar handle)
 
 ghciConfig :: ProcessConfig Handle Handle ()
 ghciConfig =
   setStdin createPipe $
     setStdout createPipe $
       shell
         "docker run -i --rm haskell 2>&1"
-
-ghciInputParser :: Parser Text
-ghciInputParser = do
-  void $ "ghci: "
-  Text.pack <$> many1 anyChar

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

@@ -1,31 +1,36 @@
 -- | The Simplest Bot. This module serves as an introductory example
 -- for bot construction.
 module Data.Chat.Bot.Hello
-  ( helloSimpleBot,
-    helloMatrixBot,
+  ( -- * Bot
+    helloBot,
+
+    -- * Serializer
+    helloBotSerializer,
+    helloBotParser,
   )
 where
 
 --------------------------------------------------------------------------------
 
-import Control.Monad.ListT (emptyListT)
 import Data.Chat.Bot
-import Data.Chat.Server.Matrix
+import Data.Chat.Bot.Serialization
 import Data.Text (Text)
 import Data.Text qualified as Text
 
 --------------------------------------------------------------------------------
 
--- | A pure, stateless bot which simply takes a 'Text' input and
--- produces a 'Text' output from it.
-helloSimpleBot :: Monad m => Bot m s Text Text
-helloSimpleBot = Bot $ \s msg ->
+-- | A pure, stateless bot which produces a 'Text' output.
+helloBot :: Monad m => Bot m s () Text
+helloBot = Bot $ \s () -> pure ("Are you talking to me, punk?", s)
+
+--------------------------------------------------------------------------------
+
+helloBotParser :: Text -> Maybe ()
+helloBotParser msg =
   let name = "cofree-bot"
    in if name `Text.isInfixOf` msg
-        then pure ("Are you talking to me, punk?", s)
-        else emptyListT
+        then Just ()
+        else Nothing
 
--- | We can then embed our bot in the Matrix API using
--- 'liftSimpleBot'.
-helloMatrixBot :: Monad m => Bot m () (RoomID, Event) (RoomID, Event)
-helloMatrixBot = embedTextBot helloSimpleBot
+helloBotSerializer :: TextSerializer Text ()
+helloBotSerializer = Serializer helloBotParser id

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

@@ -1,18 +1,34 @@
 module Data.Chat.Bot.Jitsi
-  ( jitsiBot,
+  ( -- * Bot
+    jitsiBot,
+
+    -- * Serializer,
+    jitsiSerializer,
   )
 where
 
 --------------------------------------------------------------------------------
 
 import Data.Chat.Bot
 import Data.Chat.Bot.Jitsi.Dictionary
-import Data.Chat.Bot.Monoidal
-import Data.Chat.Utils (indistinct)
-import Data.Profunctor
+import Data.Chat.Bot.Serialization (TextSerializer)
+import Data.Chat.Bot.Serialization qualified as S
 import Data.Text (Text)
 import Data.Vector qualified as V
-import System.Random
+import System.Random (randomRIO)
+
+--------------------------------------------------------------------------------
+
+jitsiBot :: Bot IO () () Text
+jitsiBot = liftEffect jitsiUrl
+
+--------------------------------------------------------------------------------
+
+jitsiSerializer :: TextSerializer Text ()
+jitsiSerializer = S.Serializer {parser, printer = id}
+
+parser :: Text -> Maybe ()
+parser i = if (i == "🍐" || i == "pair" || i == "pair") then Just () else Nothing
 
 --------------------------------------------------------------------------------
 
@@ -21,21 +37,11 @@ pickRandomElement vs = do
   i <- randomRIO (0, V.length vs)
   pure $ vs V.! i
 
-jitsiBot' :: IO Text
-jitsiBot' = do
+jitsiUrl :: IO Text
+jitsiUrl = do
   adjective <- pickRandomElement adjectives
   noun <- pickRandomElement pluralNouns
   verb <- pickRandomElement verbs
   adverb <- pickRandomElement adverbs
   let url = "https://meet.jit.si/" <> adjective <> noun <> verb <> adverb
   pure $ url
-
-jitsiBot :: Bot IO () Text Text
-jitsiBot =
-  dimap
-    ( \i ->
-        if (i == "🍐" || i == "pair" || i == "pair") then Right () else Left ()
-    )
-    indistinct
-    $ emptyBot
-      \/ liftEffect jitsiBot'