Merge pull request #812 from tsoding/598

(#598) Reimplement dispatchCustomCommand with Reaction API

Author: rexim

src/Bot.hs

@@ -668,7 +668,7 @@ dispatchRedirect :: Effect () -> Message (Command T.Text) -> Effect ()
 dispatchRedirect effect cmd = do
   effectOutput <-
     T.strip . T.concat . concatMap (\x -> [" ", x]) <$> listen effect
-  dispatchCommand $
+  runReaction dispatchCommand $
     getCompose ((\x -> T.concat [x, effectOutput]) <$> Compose cmd)
 
 -- TODO(#414): there is not cooldown for pipes
@@ -699,18 +699,18 @@ dispatchPipe = Reaction dispatchPipe'
         pipeLimit = 10
         plebPipeLimit = 2
 
-dispatchCommand :: Message (Command T.Text) -> Effect ()
-dispatchCommand message = do
-  dispatchBuiltinCommand message
-  dispatchCustomCommand message
+dispatchCommand :: Reaction Message (Command T.Text)
+dispatchCommand = dispatchBuiltinCommand <> dispatchCustomCommand
 
-dispatchBuiltinCommand :: Message (Command T.Text) -> Effect ()
-dispatchBuiltinCommand message@Message { messageSender = _
-                                       , messageContent = Command { commandName = name
-                                                                  , commandArgs = args
-                                                                  }
-                                       } =
-  maybe
-    (return ())
-    (\bc -> runReaction (bcReaction bc) $ fmap (const args) message)
-    (M.lookup name builtinCommands)
+dispatchBuiltinCommand :: Reaction Message (Command T.Text)
+dispatchBuiltinCommand = Reaction f
+  where
+    f message@Message { messageSender = _
+                      , messageContent = Command { commandName = name
+                                                 , commandArgs = args
+                                                 }
+                      } =
+      maybe
+        (return ())
+        (\bc -> runReaction (bcReaction bc) $ fmap (const args) message)
+        (M.lookup name builtinCommands)

src/Bot/CustomCommand.hs

@@ -10,19 +10,20 @@ module Bot.CustomCommand
   , timesCustomCommand
   ) where
 
+import Bot.Expr
 import Bot.Replies
-import Bot.Variable
 import Command
 import Control.Monad
-import Control.Monad.Trans.Class
 import Control.Monad.Trans.Maybe
+import Data.Functor.Compose
 import qualified Data.Map as M
 import Data.Maybe
 import Data.Proxy
 import qualified Data.Text as T
 import Data.Time
 import Effect
 import Entity
+import HyperNerd.Parser
 import Property
 import Reaction
 import Text.InterpolatedString.QM
@@ -169,27 +170,42 @@ updateCustomCommand builtinCommands =
       (Nothing, Nothing) ->
         replyToSender sender [qms|Command '{name}' does not exist|]
 
+evalExpr :: M.Map T.Text T.Text -> Expr -> T.Text
+evalExpr _ (TextExpr t) = t
+evalExpr vars (FunCallExpr "or" args) =
+  fromMaybe "" $ listToMaybe $ dropWhile T.null $ map (evalExpr vars) args
+evalExpr vars (FunCallExpr funame _) = fromMaybe "" $ M.lookup funame vars
+
+expandVars :: M.Map T.Text T.Text -> [Expr] -> T.Text
+expandVars vars = T.concat . map (evalExpr vars)
+
 -- TODO(#598): reimplement expandCustomCommandVars with Bot.Expr when it's ready
 expandCustomCommandVars ::
-     Sender -> T.Text -> CustomCommand -> Effect CustomCommand
-expandCustomCommandVars sender args customCommand = do
+     Message (Command T.Text, Entity CustomCommand)
+  -> Effect (Either String CustomCommand)
+expandCustomCommandVars Message { messageSender = sender
+                                , messageContent = (Command {commandArgs = args}, Entity {entityPayload = customCommand})
+                                } = do
   timestamp <- now
   let day = utctDay timestamp
   let (yearNum, monthNum, dayNum) = toGregorian day
-  let message = customCommandMessage customCommand
+  let code = runParser exprs $ customCommandMessage customCommand
   let times = customCommandTimes customCommand
   let vars =
-        [ ("%times", [qms|{times}|])
-        , ("%year", [qms|{yearNum}|])
-        , ("%month", [qms|{monthNum}|])
-        , ("%day", [qms|{dayNum}|])
-        , ("%date", [qms|{showGregorian day}|])
-        , ("%sender", mentionSender sender)
-        , ("%1", args)
-        ]
-  expandedMessage <-
-    expandVariables $ foldl (flip $ uncurry T.replace) message vars
-  return $ customCommand {customCommandMessage = expandedMessage}
+        M.fromList
+          [ ("times", [qms|{times}|])
+          , ("year", [qms|{yearNum}|])
+          , ("month", [qms|{monthNum}|])
+          , ("day", [qms|{dayNum}|])
+          , ("date", [qms|{showGregorian day}|])
+          , ("sender", mentionSender sender)
+          , ("1", args)
+          ]
+  case code of
+    Left msg -> return $ Left (show msg)
+    Right (_, code') ->
+      return $
+      Right customCommand {customCommandMessage = expandVars vars code'}
 
 bumpCustomCommandTimes :: CustomCommand -> CustomCommand
 bumpCustomCommandTimes customCommand =
@@ -199,19 +215,17 @@ replaceCustomCommandMessage :: T.Text -> CustomCommand -> CustomCommand
 replaceCustomCommandMessage message customCommand =
   customCommand {customCommandMessage = message}
 
-dispatchCustomCommand :: Message (Command T.Text) -> Effect ()
-dispatchCustomCommand Message { messageContent = Command { commandName = cmd
-                                                         , commandArgs = args
-                                                         }
-                              , messageSender = sender
-                              } = do
-  customCommand <-
-    runMaybeT
-      (entityPayload <$>
-       ((fmap bumpCustomCommandTimes <$> customCommandByName cmd) >>=
-        MaybeT . updateEntityById) >>=
-       lift . expandCustomCommandVars sender args)
-  maybe
-    (return ())
-    (say (senderChannel sender) . customCommandMessage)
-    customCommand
+dispatchCustomCommand :: Reaction Message (Command T.Text)
+dispatchCustomCommand =
+  liftFst (runMaybeT . customCommandByName . commandName) $
+  cmapR f $
+  ignoreNothing $
+  transR Compose $
+  liftR (updateEntityById . fmap bumpCustomCommandTimes) $
+  ignoreNothing $
+  transR getCompose $
+  dupLiftR expandCustomCommandVars $
+  replyLeft $ cmapR customCommandMessage sayMessage
+  where
+    f :: Functor m => (a, m b) -> m (a, b)
+    f = uncurry $ fmap . (,)

src/Bot/Periodic.hs

@@ -84,7 +84,7 @@ getPeriodicCommandByName name =
   Take 1 $ Filter (PropertyEquals "name" (PropertyText name)) All
 
 startPeriodicTimer ::
-     (Message (Command T.Text) -> Effect ()) -> Channel -> Int -> Effect ()
+     Reaction Message (Command T.Text) -> Channel -> Int -> Effect ()
 startPeriodicTimer dispatchCommand channel eid =
   periodicEffect' (Just channel) $ do
     pt' <- getEntityById Proxy eid
@@ -99,15 +99,15 @@ startPeriodicTimer dispatchCommand channel eid =
          when (periodicTimerEnabled pt) $
            maybe
              (return ())
-             (dispatchCommand .
+             (runReaction dispatchCommand .
               Message (mrbotka {senderChannel = channel}) False .
               periodicCommand . entityPayload)
              pc'
          return $ Just $ fromIntegral $ periodicTimerPeriod pt)
       pt'
 
 startPeriodicCommands ::
-     Channel -> (Message (Command T.Text) -> Effect ()) -> Effect ()
+     Channel -> Reaction Message (Command T.Text) -> Effect ()
 startPeriodicCommands channel dispatchCommand = do
   eids <- (entityId <$>) <$> selectEntities (Proxy :: Proxy PeriodicTimer) All
   for_ eids (startPeriodicTimer dispatchCommand channel)
@@ -171,7 +171,7 @@ statusPeriodicTimerCommand =
   Reaction replyMessage
 
 addPeriodicTimerCommand ::
-     (Message (Command T.Text) -> Effect ()) -> Reaction Message Int
+     Reaction Message (Command T.Text) -> Reaction Message Int
 addPeriodicTimerCommand dispatchCommand =
   cmapR (PeriodicTimer False) $
   liftR (createEntity Proxy) $

src/Reaction.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE TupleSections #-}
+
 module Reaction where
 
 import Data.Functor
@@ -74,3 +76,9 @@ ifR predicate thenReaction elseReaction =
     if predicate $ extract x
       then runReaction thenReaction x
       else runReaction elseReaction x
+
+liftFst :: Comonad w => (a -> Effect b) -> Reaction w (a, b) -> Reaction w a
+liftFst f r =
+  Reaction $ \m -> do
+    b <- f $ extract m
+    runReaction r ((, b) <$> m)