Add lenses to listing and use them in the example bot

src/Haboli/Euphoria/ExampleBot.hs

@@ -1,7 +1,13 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
 
 -- | This module contains an example implementation of a small bot. It is a good
 -- starting point if you want to create your own bot.
+--
+-- The example bot uses lenses for its state because they vastly reduce the
+-- amount of code required to update the 'Listing' inside the state. It is
+-- entirely possible to use haboli without lenses though, should you want to do
+-- that.
 
 module Haboli.Euphoria.ExampleBot
   ( exampleBot
@@ -14,15 +20,19 @@ import           Data.List
 import qualified Data.Map.Strict          as Map
 import qualified Data.Text                as T
 import           Data.Time
+import           Lens.Micro
+import           Lens.Micro.TH
 
 import           Haboli.Euphoria
 import           Haboli.Euphoria.Botrulez
 
 data BotState = BotState
-  { botStartTime :: UTCTime
+  { _botStartTime :: UTCTime
-  , botListing   :: Listing
+  , _botListing   :: Listing
   } deriving (Show)
 
+makeLenses ''BotState
+
 -- | A small example bot. Takes a room password as its first argument. You can
 -- run this bot in [&test](https://euphoria.io/room/test) like this:
 --
@@ -33,27 +43,27 @@ exampleBot mPasswd = do
   initialEvents <- untilConnected $
     respondingToBounce mPasswd $
     respondingToPing nextEvent
-  listing <- preferNick "ExampleBot" $ newListing initialEvents
+  let initialState = BotState startTime $ newListing initialEvents
-  stateVar <- liftIO $ newMVar $ BotState startTime listing
+  stateVar <- liftIO $ newMVar initialState
+  preferNickVia botListing stateVar "ExampleBot"
   botMain stateVar
 
 botMain :: MVar BotState -> Client T.Text ()
 botMain stateVar = forever $ do
   event <- respondingToCommands (getCommands stateVar) $
     respondingToPing nextEvent
-  -- Update the listing
+  updateFromEventVia botListing stateVar event
-  liftIO $ modifyMVar_ stateVar $ \state ->
-    pure state{botListing = updateFromEvent event $ botListing state}
 
 getCommands :: MVar BotState -> Client e [Command T.Text]
 getCommands stateVar = do
   state <- liftIO $ readMVar stateVar
-  let name = svNick $ self $ botListing state
+  let name = state ^. botListing . lsSelfL . svNickL
   pure
     [ botrulezPingGeneral
     , botrulezPingSpecific name
-    , botrulezHelpSpecific name "I am an example bot for https://github.com/Garmelon/haboli/."
+    , botrulezHelpSpecific name
-    , botrulezUptimeSpecific name $ botStartTime state
+        "I am an example bot for https://github.com/Garmelon/haboli/."
+    , botrulezUptimeSpecific name $ state ^. botStartTime
     , botrulezKillSpecific name
     , cmdSpecific "hug" name $ \msg -> void $ reply msg "/me hugs back"
     , cmdHello
@@ -68,15 +78,12 @@ cmdHello = cmdGeneral "hello" $ \msg -> do
 
 cmdNick :: MVar BotState -> T.Text -> Command e
 cmdNick stateVar name = cmdSpecificArgs "nick" name $ \msg args -> do
-  -- Update the listing while updating the nick
+  preferNickVia botListing stateVar args
-  state <- liftIO $ takeMVar stateVar
-  listing' <- preferNick args $ botListing state
-  liftIO $ putMVar stateVar state{botListing = listing'}
   void $ reply msg "Is this better?"
 
 cmdWho :: MVar BotState -> Command e
 cmdWho stateVar = cmdGeneral "who" $ \msg -> do
   state <- liftIO $ readMVar stateVar
-  let people = others $ botListing state
+  let people = state ^. botListing . lsOthersL
       nicks = sort $ map svNick $ Map.elems people
   void $ reply msg $ T.intercalate "\n" nicks

src/Haboli/Euphoria/Listing.hs

@@ -1,34 +1,49 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE TemplateHaskell   #-}
 
 -- | A 'Listing' helps keep track of a bot's own 'SessionView' as well as all
 -- other clients connected to a room. It must be kept up-to-date manually.
 
 module Haboli.Euphoria.Listing
-  ( Listing
+  ( Listing(..)
+  , lsSelfL
+  , lsOthersL
   , newListing
-  , self
-  , others
   , updateOwnNick
   , preferNick
+  , preferNickVia
   , updateFromList
+  , updateFromListVia
   , updateFromEvent
+  , updateFromEventVia
   ) where
 
+import           Control.Concurrent
+import           Control.Monad.IO.Class
 import qualified Data.Map.Strict        as Map
 import           Data.Maybe
 import qualified Data.Text              as T
+import           Lens.Micro
 
 import           Haboli.Euphoria.Api
 import           Haboli.Euphoria.Client
+import           Haboli.Euphoria.Lens
 
--- | A listing contains a bot's own 'SessionView' (accessible via 'self') and a
+-- | A listing contains a bot's own 'SessionView' (accessible via 'lsSelf') and a
 -- map of all other clients currently connected to the room (accessible via
--- 'others'). The latter never includes the bot itself.
+-- 'lsOthers'). The latter never includes the bot itself.
 data Listing = Listing
   { lsSelf   :: SessionView
+  -- ^ The 'SessionView' describing the bot itself.
   , lsOthers :: Map.Map UserId SessionView
+  -- ^ The 'SessionView's describing the other clients connected to the current
+  -- room. Does not include the bot's own 'SessionView' (use 'lsSelf' to access
+  -- that).
   } deriving (Show)
 
+makeLensesL ''Listing
+
 othersFromList :: [SessionView] -> Map.Map UserId SessionView
 othersFromList sessions = Map.fromList [(svId sv, sv) | sv <- sessions]
 
@@ -39,29 +54,28 @@ newListing (h, s) = Listing
   , lsOthers = othersFromList $ snapshotListing s
   }
 
--- | The 'SessionView' describing the bot itself.
-self :: Listing -> SessionView
-self = lsSelf
-
--- | The 'SessionView's describing the other clients connected to the current
--- room. Does not include the bot's own 'SessionView' (use 'self' to access
--- that).
-others :: Listing -> Map.Map UserId SessionView
-others = lsOthers
-
 -- | Set the bot's own nick to a new nick.
 updateOwnNick :: T.Text -> Listing -> Listing
-updateOwnNick name listing = listing{lsSelf = (lsSelf listing){svNick = name}}
+updateOwnNick name = lsSelfL . svNickL .~ name
 
 -- | Set the bot's nick and update the 'Listing' with the server's reply in one
 -- go.
 preferNick :: T.Text -> Listing -> Client e Listing
 preferNick name listing
-  | name == svNick (self listing) = pure listing
+  | name == listing ^. lsSelfL . svNickL = pure listing
   | otherwise = do
       (_, newNick) <- nick name
       pure $ updateOwnNick newNick listing
 
+-- | Like 'preferNick', but updates a 'Listing' inside a data type inside an
+-- 'MVar'.
+preferNickVia :: Lens' a Listing -> MVar a -> T.Text -> Client e ()
+preferNickVia field mvar name = do
+  a <- liftIO $ takeMVar mvar
+  listing' <- preferNick name $ a ^. field
+  let a' = a & field .~ listing'
+  liftIO $ putMVar mvar a'
+
 -- | Update a 'Listing' from a list of sessions currently connected to the room.
 -- Afterwards, the 'Listing' will contain only those sessions present in the
 -- list.
@@ -73,22 +87,30 @@ updateFromList sessions listing =
       newOthers = Map.filterWithKey (\k _ -> k /= ownId) others'
   in  Listing newSelf newOthers
 
-onJoin :: SessionView -> Listing -> Listing
+-- | Like 'updateFromList', but updates a 'Listing' inside a data type inside an
-onJoin sv listing = listing{lsOthers = Map.insert (svId sv) sv $ lsOthers listing}
+-- 'MVar'.
-
+updateFromListVia :: Lens' a Listing -> MVar a -> [SessionView] -> Client e ()
-onPart :: SessionView -> Listing -> Listing
+updateFromListVia field mvar list =
-onPart sv listing = listing{lsOthers = Map.delete (svId sv) $ lsOthers listing}
+  liftIO $ modifyMVar_ mvar $ pure . (field %~ updateFromList list)
 
 -- | Update a 'Listing' based on an 'Event'. Follows the euphoria documentation
 -- for 'JoinEvent', 'PartEvent' and 'NetworkEvent'.
 updateFromEvent :: Event -> Listing -> Listing
-updateFromEvent (EventJoin e) listing = onJoin (joinSession e) listing
+updateFromEvent (EventJoin e) listing =
-updateFromEvent (EventPart e) listing = onPart (partSession e) listing
+  let sv = joinSession e
+  in  listing & lsOthersL %~ Map.insert (svId sv) sv
+updateFromEvent (EventPart e) listing =
+  let sv = partSession e
+  in  listing & lsOthersL %~ Map.delete (svId sv)
 updateFromEvent (EventNetwork e) listing | networkType e == "partition" =
   let sId = networkServerId e
       sEra = networkServerEra e
       isAffected sv = svServerId sv == sId && svServerEra sv == sEra
-      others' = Map.filter (not . isAffected) $ lsOthers listing
+  in  listing & lsOthersL %~ Map.filter (not . isAffected)
-  in  listing{lsOthers = others'}
 updateFromEvent _ listing = listing
 
+-- | Like 'updateFromEvent', but updates a 'Listing' inside a data type inside
+-- an 'MVar'.
+updateFromEventVia :: Lens' a Listing -> MVar a -> Event -> Client e ()
+updateFromEventVia field mvar event =
+  liftIO $ modifyMVar_ mvar $ pure . (field %~ updateFromEvent event)