From fd4ae38eb1d3c3933f492ab69ab9ecedfeee03df Mon Sep 17 00:00:00 2001
From: Joscha <joscha@plugh.de>
Date: Tue, 7 Apr 2020 18:39:42 +0000
Subject: [PATCH] Add abstraction for bot commands

---
 CHANGELOG.md                   |  1 +
 haboli.cabal                   |  3 +-
 src/Haboli/Euphoria/Client.hs  |  7 ++--
 src/Haboli/Euphoria/Command.hs | 66 ++++++++++++++++++++++++++++++++++
 4 files changed, 74 insertions(+), 3 deletions(-)
 create mode 100644 src/Haboli/Euphoria/Command.hs

diff --git a/CHANGELOG.md b/CHANGELOG.md
index a070433..0d72c89 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,6 +1,7 @@
 # Changelog for haboli
 
 ## upcoming
+- add `Haboli.Euphoria.Command` module
 - clean up project
 - fix nick of example bot in readme
 
diff --git a/haboli.cabal b/haboli.cabal
index cbd7951..9c730ed 100644
--- a/haboli.cabal
+++ b/haboli.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 9b4e31fd51c5402b511dfcd2fa3dd52e562b202b1583f6639a0e193920e0d02c
+-- hash: bcd1c482ca0554443e9e0523bf9eb0cc65354ef37c4aec33570b5ab9a22502bf
 
 name:           haboli
 version:        0.3.1.0
@@ -32,6 +32,7 @@ library
       Haboli.Euphoria
       Haboli.Euphoria.Api
       Haboli.Euphoria.Client
+      Haboli.Euphoria.Command
       Haboli.Euphoria.Example
       Haboli.Euphoria.WegaBorad
   other-modules:
diff --git a/src/Haboli/Euphoria/Client.hs b/src/Haboli/Euphoria/Client.hs
index ded43dc..d6f54ea 100644
--- a/src/Haboli/Euphoria/Client.hs
+++ b/src/Haboli/Euphoria/Client.hs
@@ -317,8 +317,11 @@ nextEvent = do
     Right e -> pure e
 
 -- | Respond to 'EventPing's according to the documentation (see
--- <http://api.euphoria.io/#ping-event>). This function is meant to be wrapped
--- directly around 'nextEvent':
+-- <http://api.euphoria.io/#ping-event>). Passes through all events unmodified.
+--
+-- This utility function is meant to be wrapped directly or indirectly around
+-- 'nextEvent':
+--
 -- > event <- respondingToPing nextEvent
 respondingToPing :: Client e Event -> Client e Event
 respondingToPing holdingEvent = do
diff --git a/src/Haboli/Euphoria/Command.hs b/src/Haboli/Euphoria/Command.hs
new file mode 100644
index 0000000..09f402c
--- /dev/null
+++ b/src/Haboli/Euphoria/Command.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE MultiParamTypeClasses     #-}
+
+-- | This module provides an abstraction for bot commands in the form of the
+-- 'Hook' type class and the 'Command' type.
+
+module Haboli.Euphoria.Command
+  ( Hook(..)
+  , Command
+  , cmd
+  , runCommand
+  , runCommands
+  , respondingToCommands
+  ) where
+
+import           Control.Monad
+
+import           Haboli.Euphoria.Api
+import           Haboli.Euphoria.Client
+
+-- | A hook is a way to react to new messages in a room. These typically don't
+-- include the messages sent by the client itself.
+class Hook h where
+  -- | @reel h msg@ applies the hook @h@ to the 'Message' @msg@. If no further
+  -- hooks should be applied to this message, it should return 'True'.
+  -- Otherwise, it should return 'False'.
+  reel :: h e -> Message -> Client e Bool
+
+-- | A wrapper around hooks that allows for heterogenous lists of hooks. In
+-- other words, it lets you combine different 'Hook' instances into a single
+-- list.
+data Command e = forall h. (Hook h) => Command (h e)
+
+-- | Wrap a hook. Notice how the @h@ type disappears: This function can convert
+-- different 'Hook' instances into the same type.
+cmd :: (Hook h) => h e -> Command e
+cmd = Command
+
+-- | Apply a 'Command' to a 'Message'. For more information, see 'reel'.
+runCommand :: Command e -> Message -> Client e Bool
+runCommand (Command h) = reel h
+
+-- | Apply multiple 'Command's to a 'Message' in order until one returns 'True'.
+-- All commands following that one are not applied.
+runCommands :: [Command e] -> Message -> Client e Bool
+runCommands [] _ = pure False
+runCommands (c:cs) msg = do
+  abort <- runCommand c msg
+  if abort
+    then pure True
+    else runCommands cs msg
+
+-- | Run a list of 'Command's on all 'EventSend's. Passes through all events
+-- unmodified.
+--
+-- This utility function is meant to be wrapped directly or indirectly around
+-- 'nextEvent':
+--
+-- > event <- respondingToCommands commands nextEvent
+respondingToCommands :: [Command e] -> Client e Event -> Client e Event
+respondingToCommands cmds holdingEvent = do
+  event <- holdingEvent
+  case event of
+    EventSend e -> void $ runCommands cmds $ sendMessage e
+    _           -> pure ()
+  pure event