Initial commit

src/Bot/DSL.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE Safe            #-}
+module Bot.DSL
+  ( module Bot.DSL.Network
+  , module Bot.DSL.State
+  , module Bot.DSL.Time
+  , MonadBot
+  , MonadExtension
+  ) where
+
+import           Control.Monad.Logger
+
+import           Bot.DSL.Network
+import           Bot.DSL.State
+import           Bot.DSL.Time
+
+type MonadBot m = (MonadNetwork m, MonadData m, MonadLogger m, MonadTime m)
+type MonadExtension m = (MonadData m, MonadLogger m, MonadTime m)

src/Bot/DSL/Network.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE Safe                  #-}
+{-# LANGUAGE TypeFamilies          #-}
+module Bot.DSL.Network where
+
+import           Data.Text (Text)
+
+data Request meta = Request { content :: Text
+                            , meta    :: meta }
+data Response meta = Response { content :: Text
+                              , meta    :: meta }
+
+class Monad m => MonadNetwork m where
+  -- Meta for stuff like event types, or source / target information
+  type Meta m :: *
+  recvMsg :: m (Request (Meta m))
+  putMsg :: Response (Meta m) -> m ()

src/Bot/DSL/State.hs

@@ -0,0 +1,5 @@
+module Bot.DSL.State where
+
+class Monad m => MonadData m where
+  getData :: Read a => String -> m (Maybe a)
+  putData :: Show a => String -> a -> m ()

src/Bot/DSL/Time.hs

@@ -0,0 +1,6 @@
+module Bot.DSL.Time where
+
+import qualified Data.Time as Time
+
+class Monad m => MonadTime m where
+  getCurrentTime :: m Time.UTCTime

src/Bot/Extension.hs

@@ -0,0 +1,9 @@
+{-# Language Safe #-}
+{-# Language RankNTypes #-}
+{-# Language GADTs #-}
+module Bot.Extension where
+
+import Bot.DSL
+
+data Extension meta = Extension { act :: forall m. (meta ~ Meta m, MonadExtension m) => Request meta -> m (Maybe (Response meta))
+                             , name   :: String }

src/Bot/Lib.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE Safe                #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Bot.Lib where
+
+import           Bot.DSL
+import           Bot.Extension
+import           Bot.Log
+import           Control.Monad       (forever)
+import           Control.Monad.Catch (MonadCatch, SomeException, catch, try)
+import           Data.Maybe          (catMaybes)
+import qualified Data.Text           as T
+import           GHC.Stack
+
+tshow :: Show a => a -> T.Text
+tshow = T.pack . show
+
+mainLoop :: forall m. (MonadCatch m, MonadBot m) => [Extension (Meta m)] -> m ()
+mainLoop extensions = forever $ catch go handleFail
+  where
+    handleFail :: SomeException -> m ()
+    handleFail e = logError $ tshow e
+    go :: m ()
+    go = do
+      msg <- recvMsg
+      responses <- catMaybes <$> mapM (\ext -> (act ext) msg) extensions
+      mapM_ putMsg responses

src/Bot/Log.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE Safe             #-}
+module Bot.Log where
+
+import           Control.Monad.Logger (MonadLogger)
+import qualified Control.Monad.Logger as Log
+import           Data.Text            (Text)
+import           GHC.Stack
+
+logInfo :: (HasCallStack, MonadLogger m) => Text -> m ()
+logInfo = Log.logInfoCS callStack
+
+logError :: (HasCallStack, MonadLogger m) => Text -> m ()
+logError = Log.logErrorCS callStack