module Marvin.Internal where
import Control.Monad.Reader
import Control.Monad.State
import qualified Data.Configurator as C
import qualified Data.Configurator.Types as C
import Control.Lens hiding (cons)
import Control.Monad.Logger
import Data.Monoid ((<>))
import Data.Sequences
import qualified Data.Text.Lazy as L
import Marvin.Adapter (IsAdapter)
import qualified Marvin.Adapter as A
import Marvin.Internal.Types
import Marvin.Interpolate.Text
import Marvin.Util.Regex (Match, Regex)
import Util
declareFields [d|
data BotActionState a d = BotActionState
{ botActionStateScriptId :: ScriptId
, botActionStateConfig :: C.Config
, botActionStateAdapter :: a
, botActionStateVariable :: d
}
|]
declareFields [d|
data MessageReactionData = MessageReactionData
{ messageReactionDataMessageField :: Message
, messageReactionDataMatchField :: Match
}
|]
type Topic = L.Text
data ActionData d where
Hear :: Regex -> ActionData MessageReactionData
Respond :: Regex -> ActionData MessageReactionData
Join :: ActionData (User, Channel)
JoinIn :: L.Text -> ActionData (User, Channel)
Leave :: ActionData (User, Channel)
LeaveFrom :: L.Text -> ActionData (User, Channel)
TopicC :: ActionData (Topic, Channel)
TopicCIn :: L.Text -> ActionData (Topic, Channel)
Custom :: (A.Event -> Maybe d) -> ActionData d
data WrappedAction a = forall d. WrappedAction (ActionData d) (BotReacting a d ())
newtype BotReacting a d r = BotReacting { runReaction :: ReaderT (BotActionState a d) RunnerM r } deriving (Monad, MonadIO, Applicative, Functor, MonadReader (BotActionState a d), MonadLogger)
declareFields [d|
data Script a = Script
{ scriptActions :: [WrappedAction a]
, scriptScriptId :: ScriptId
, scriptConfig :: C.Config
, scriptAdapter :: a
}
|]
newtype ScriptDefinition a r = ScriptDefinition { runScript :: StateT (Script a) RunnerM r } deriving (Monad, MonadIO, Applicative, Functor, MonadLogger)
newtype ScriptInit a = ScriptInit (ScriptId, a -> C.Config -> RunnerM (Script a))
class HasMessage m where
messageLens :: Lens' m Message
instance HasMessageField m Message => HasMessage m where
messageLens = messageField
class HasMatch m where
matchLens :: Lens' m Match
instance HasMatchField m Match => HasMatch m where
matchLens = matchField
class HasTopic m where
topicLens :: Lens' m L.Text
instance HasTopic (Topic, a) where
topicLens = _1
idLens :: Lens' a a
idLens = lens id (flip const)
class HasChannel a where
channelLens :: Lens' a Channel
instance HasChannel (a, Channel) where
channelLens = _2
instance HasChannel MessageReactionData where
channelLens = messageField . lens channel (\a b -> a {channel = b})
class HasUser a where
userLens :: Lens' a User
instance HasUser User where
userLens = idLens
instance HasUser (User, a) where
userLens = _1
instance HasUser MessageReactionData where
userLens = messageField . lens sender (\a b -> a {sender = b})
instance HasConfigAccess (ScriptDefinition a) where
getConfigInternal = ScriptDefinition $ use config
instance HasConfigAccess (BotReacting a b) where
getConfigInternal = view config
instance IsScript (ScriptDefinition a) where
getScriptId = ScriptDefinition $ use scriptId
instance IsScript (BotReacting a b) where
getScriptId = view scriptId
class AccessAdapter m where
type AdapterT m
getAdapter :: m (AdapterT m)
instance AccessAdapter (ScriptDefinition a) where
type AdapterT (ScriptDefinition a) = a
getAdapter = ScriptDefinition $ use adapter
instance AccessAdapter (BotReacting a b) where
type AdapterT (BotReacting a b) = a
getAdapter = view adapter
getSubConfFor :: HasConfigAccess m => ScriptId -> m C.Config
getSubConfFor (ScriptId name) = C.subconfig ("script." <> name) <$> getConfigInternal
getConfig :: HasConfigAccess m => m C.Config
getConfig = getScriptId >>= getSubConfFor
addReaction :: ActionData d -> BotReacting a d () -> ScriptDefinition a ()
addReaction data_ action = ScriptDefinition $ actions %= cons (WrappedAction data_ action)
hear :: Regex -> BotReacting a MessageReactionData () -> ScriptDefinition a ()
hear !re = addReaction (Hear re)
respond :: Regex -> BotReacting a MessageReactionData () -> ScriptDefinition a ()
respond !re = addReaction (Respond re)
enter :: BotReacting a (User, Channel) () -> ScriptDefinition a ()
enter = addReaction Join
exit :: BotReacting a (User, Channel) () -> ScriptDefinition a ()
exit = addReaction Leave
enterIn :: L.Text -> BotReacting a (User, Channel) () -> ScriptDefinition a ()
enterIn !chanName = addReaction (JoinIn chanName)
exitFrom :: L.Text -> BotReacting a (User, Channel) () -> ScriptDefinition a ()
exitFrom !chanName = addReaction (LeaveFrom chanName)
topic :: BotReacting a (Topic, Channel) () -> ScriptDefinition a ()
topic = addReaction TopicC
topicIn :: L.Text -> BotReacting a (Topic, Channel) () -> ScriptDefinition a ()
topicIn !chanName = addReaction (TopicCIn chanName)
customTrigger :: (A.Event -> Maybe d) -> BotReacting a d () -> ScriptDefinition a ()
customTrigger tr = addReaction (Custom tr)
send :: (IsAdapter a, HasChannel m) => L.Text -> BotReacting a m ()
send msg = do
o <- getChannel
messageChannel' o msg
getUsername :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => User -> m L.Text
getUsername usr = do
a <- getAdapter
A.liftAdapterAction $ A.getUsername a usr
resolveChannel :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => L.Text -> m (Maybe Channel)
resolveChannel name = do
a <- getAdapter
A.liftAdapterAction $ A.resolveChannel a name
getChannelName :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Channel -> m L.Text
getChannelName rm = do
a <- getAdapter
A.liftAdapterAction $ A.getChannelName a rm
reply :: (IsAdapter a, HasMessage m) => L.Text -> BotReacting a m ()
reply msg = do
om <- getMessage
user <- getUsername $ sender om
messageChannel' (channel om) $ user <> " " <> msg
messageChannel :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m, MonadLogger m) => L.Text -> L.Text -> m ()
messageChannel name msg = do
mchan <- resolveChannel name
maybe ($logError $(isT "No channel known with the name #{name}")) (`messageChannel'` msg) mchan
messageChannel' :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Channel -> L.Text -> m ()
messageChannel' chan msg = do
a <- getAdapter
A.liftAdapterAction $ A.messageChannel a chan msg
defineScript :: ScriptId -> ScriptDefinition a () -> ScriptInit a
defineScript sid definitions =
ScriptInit (sid, runDefinitions sid definitions)
runDefinitions :: ScriptId -> ScriptDefinition a () -> a -> C.Config -> RunnerM (Script a)
runDefinitions sid definitions ada cfg = execStateT (runScript definitions) (Script mempty sid cfg ada)
getData :: BotReacting a d d
getData = view variable
getMatch :: HasMatch m => BotReacting a m Match
getMatch = view (variable . matchLens)
getMessage :: HasMessage m => BotReacting a m Message
getMessage = view (variable . messageLens)
getTopic :: HasTopic m => BotReacting a m Topic
getTopic = view (variable . topicLens)
getChannel :: HasChannel m => BotReacting a m Channel
getChannel = view (variable . channelLens)
getUser :: HasUser m => BotReacting a m User
getUser = view (variable . userLens)
getConfigVal :: (C.Configured a, HasConfigAccess m) => C.Name -> m (Maybe a)
getConfigVal name = do
cfg <- getConfig
liftIO $ C.lookup cfg name
requireConfigVal :: (C.Configured a, HasConfigAccess m) => C.Name -> m a
requireConfigVal name = do
cfg <- getConfig
liftIO $ C.require cfg name
getAppConfig :: HasConfigAccess m => m C.Config
getAppConfig = getSubConfFor applicationScriptId
getAppConfigVal :: (C.Configured a, HasConfigAccess m) => C.Name -> m (Maybe a)
getAppConfigVal name = do
cfg <- getAppConfig
liftIO $ C.lookup cfg name
requireAppConfigVal :: (C.Configured a, HasConfigAccess m) => C.Name -> m a
requireAppConfigVal name = do
cfg <- getAppConfig
liftIO $ C.require cfg name
extractReaction :: BotReacting a s o -> BotReacting a s (IO o)
extractReaction reac = BotReacting $ do
s <- ask
return $ runStderrLoggingT $ runReaderT (runReaction reac) s
extractAction :: BotReacting a () o -> ScriptDefinition a (IO o)
extractAction ac = ScriptDefinition $ do
a <- use adapter
sid <- use scriptId
cfg <- use config
return $ runStderrLoggingT $ runReaderT (runReaction ac) (BotActionState sid cfg a ())