diff --git a/src/Bot.hs b/src/Bot.hs index 45aadd3..cfd3478 100644 --- a/src/Bot.hs +++ b/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) diff --git a/src/Bot/CustomCommand.hs b/src/Bot/CustomCommand.hs index 9c6b3b2..303dceb 100644 --- a/src/Bot/CustomCommand.hs +++ b/src/Bot/CustomCommand.hs @@ -10,12 +10,12 @@ 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 @@ -23,6 +23,7 @@ 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 . (,) diff --git a/src/Bot/Periodic.hs b/src/Bot/Periodic.hs index cad7dc7..be67adb 100644 --- a/src/Bot/Periodic.hs +++ b/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,7 +99,7 @@ startPeriodicTimer dispatchCommand channel eid = when (periodicTimerEnabled pt) $ maybe (return ()) - (dispatchCommand . + (runReaction dispatchCommand . Message (mrbotka {senderChannel = channel}) False . periodicCommand . entityPayload) pc' @@ -107,7 +107,7 @@ startPeriodicTimer dispatchCommand channel eid = 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) $ diff --git a/src/Reaction.hs b/src/Reaction.hs index b29dd9c..fce312b 100644 --- a/src/Reaction.hs +++ b/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)