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 Data.Monoid ((<>))
import Data.Sequences
import Marvin.Adapter (IsAdapter)
import qualified Marvin.Adapter as A
import Marvin.Internal.Types
import Marvin.Util.Logging
import Marvin.Util.Regex (Match, Regex)
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
}
|]
data ActionData d where
Hear :: Regex -> ActionData MessageReactionData
Respond :: Regex -> ActionData MessageReactionData
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) IO r } deriving (Monad, MonadIO, Applicative, Functor, MonadReader (BotActionState a d))
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) IO r } deriving (Monad, MonadIO, Applicative, Functor)
newtype ScriptInit a = ScriptInit (ScriptId, a -> C.Config -> IO (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
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)
customTrigger :: (A.Event -> Maybe d) -> BotReacting a d () -> ScriptDefinition a ()
customTrigger tr = addReaction (Custom tr)
send :: (IsAdapter a, HasMessage m) => String -> BotReacting a m ()
send msg = do
o <- getMessage
messageChannel' (channel o) msg
getUsername :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => User -> m String
getUsername usr = do
a <- getAdapter
liftIO $ A.getUsername a usr
resolveChannel :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => String -> m (Maybe Channel)
resolveChannel name = do
a <- getAdapter
liftIO $ A.resolveChannel a name
getChannelName :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Channel -> m String
getChannelName rm = do
a <- getAdapter
liftIO $ A.getChannelName a rm
reply :: (IsAdapter a, HasMessage m) => String -> BotReacting a m ()
reply msg = do
om <- getMessage
user <- getUsername $ sender om
send $ user ++ " " ++ msg
messageChannel :: (AccessAdapter m, IsAdapter (AdapterT m), IsScript m, MonadIO m) => String -> String -> m ()
messageChannel name msg = do
mchan <- resolveChannel name
maybe (errorM $ "No channel known with the name " ++ name) (`messageChannel'` msg) mchan
messageChannel' :: (AccessAdapter m, IsAdapter (AdapterT m), IsScript m, MonadIO m) => Channel -> String -> m ()
messageChannel' chan msg = do
a <- getAdapter
liftIO $ 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 -> IO (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)
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 $ 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 $ runReaderT (runReaction ac) (BotActionState sid cfg a ())