Add example bot

CHANGELOG.md

@@ -4,6 +4,7 @@
 - add `Haboli.Euphoria.Command` module and submodules
 - add `Haboli.Euphoria.Listing` module
 - add `Haboli.Euphoria.Util` module and move `respondingToPing` there
+- add example bot (`Haboli.Euphoria.ExampleBot`)
 - clean up project
 - fix nick of example bot in readme
 - remove `Haboli.Euphoria.Examples` module

haboli.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 9151d30bacf2317670dc6ff817bd66ca13bd3798142b0b8ad8fceb78461b4ab1
+-- hash: 15fd0a6cea4710f753e56b5d0232a7986b434e5fab8fee7855e81e311f87499c
 
 name:           haboli
 version:        0.3.1.0
@@ -35,6 +35,7 @@ library
       Haboli.Euphoria.Command
       Haboli.Euphoria.Command.Megaparsec
       Haboli.Euphoria.Command.Simple
+      Haboli.Euphoria.ExampleBot
       Haboli.Euphoria.Listing
       Haboli.Euphoria.Util
   other-modules:

src/Haboli/Euphoria/Command/Simple.hs

@@ -2,7 +2,9 @@
 
 module Haboli.Euphoria.Command.Simple
   ( cmdGeneral
+  , cmdGeneral'
   , cmdSpecific
+  , cmdSpecific'
   ) where
 
 import           Control.Monad
@@ -34,11 +36,23 @@ pUntilEof = takeWhileP Nothing (const True)
 pCmdGeneral :: T.Text -> Parser T.Text
 pCmdGeneral cmd = pCmd cmd *> space *> pUntilEof
 
-cmdGeneral :: T.Text -> (Message -> T.Text -> Client e ()) -> Command e
-cmdGeneral cmd = cmdMega $ pCmdGeneral cmd
-
 pCmdSpecific :: T.Text -> T.Text -> Parser T.Text
 pCmdSpecific cmd name = pCmd cmd *> space1 *> pNick name *> space *> pUntilEof
 
-cmdSpecific :: T.Text -> T.Text -> (Message -> T.Text -> Client e ()) -> Command e
+pWithoutArgs :: Parser T.Text -> Parser ()
-cmdSpecific name cmd = cmdMega $ pCmdSpecific cmd name
+pWithoutArgs p = do
+  args <- p
+  guard $ T.null args
+
+cmdGeneral :: T.Text -> (Message -> Client e ()) -> Command e
+cmdGeneral cmd f = cmdMega (pWithoutArgs $ pCmdGeneral cmd) $ \msg _ -> f msg
+
+cmdGeneral' :: T.Text -> (Message -> T.Text -> Client e ()) -> Command e
+cmdGeneral' cmd = cmdMega $ pCmdGeneral cmd
+
+cmdSpecific :: T.Text -> T.Text -> (Message -> Client e ()) -> Command e
+cmdSpecific cmd name f =
+  cmdMega (pWithoutArgs $ pCmdSpecific cmd name) $ \msg _ -> f msg
+
+cmdSpecific' :: T.Text -> T.Text -> (Message -> T.Text -> Client e ()) -> Command e
+cmdSpecific' cmd name = cmdMega $ pCmdSpecific cmd name

src/Haboli/Euphoria/ExampleBot.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Haboli.Euphoria.ExampleBot
+  ( BotState(..)
+  , exampleBot
+  ) where
+
+import           Control.Monad
+import           Control.Monad.Trans.Class
+import           Control.Monad.Trans.State
+import qualified Data.Text                      as T
+
+import           Haboli.Euphoria
+import           Haboli.Euphoria.Command
+import           Haboli.Euphoria.Command.Simple
+import           Haboli.Euphoria.Listing
+import           Haboli.Euphoria.Util
+
+newtype BotState = BotState
+  { botListing :: Listing
+  } deriving (Show)
+
+type Bot = StateT BotState (Client T.Text)
+
+exampleBot :: Maybe T.Text -> Client T.Text ()
+exampleBot mPasswd = do
+  initialEvents <- untilConnected $
+    respondingToBounce mPasswd $
+    respondingToPing nextEvent
+  listing <- preferNick "ExampleBot" $ newListing initialEvents
+  void $ runStateT botMain $ BotState listing
+
+botMain :: Bot ()
+botMain = forever $ do
+  s <- get
+  let name = svNick $ self $ botListing s
+  lift $ respondingToCommands
+    [ cmdGeneral "ping" $ \msg -> void $ reply msg "Pong!"
+    , cmdSpecific "ping" name $ \msg -> void $ reply msg "Pong!"
+    , cmdSpecific "help" name $ \msg ->
+        void $ reply msg "I am an example bot for https://github.com/Garmelon/haboli/."
+    , cmdSpecific "kill" name $ \msg -> do
+        void $ reply msg "/me dies"
+        throw $ "I was killed by " <> svNick (msgSender msg)
+    ] $ respondingToPing nextEvent
+

src/Haboli/Euphoria/Listing.hs

@@ -6,6 +6,7 @@ module Haboli.Euphoria.Listing
   , self
   , others
   , updateOwnNick
+  , preferNick
   , updateFromList
   , updateFromEvent
   ) where
@@ -40,6 +41,13 @@ others = lsOthers
 updateOwnNick :: T.Text -> Listing -> Listing
 updateOwnNick name listing = listing{lsSelf = (lsSelf listing){svNick = name}}
 
+preferNick :: T.Text -> Listing -> Client e Listing
+preferNick name listing
+  | name == svNick (self listing) = pure listing
+  | otherwise = do
+      (_, newNick) <- nick name
+      pure $ updateOwnNick newNick listing
+
 updateFromList :: [SessionView] -> Listing -> Listing
 updateFromList sessions listing =
   let ownId = svId $ lsSelf listing