Add abstraction for bot commands

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