Initial commit

src/AppM.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE TypeFamilies               #-}
+module AppM where
+
+import           Bot.DSL
+import           Control.Monad.Catch  (MonadCatch, MonadThrow)
+import           Control.Monad.Logger
+import           Control.Monad.Trans  (MonadIO, liftIO)
+import           Data.Text            (Text)
+import qualified Data.Text            as T
+import qualified Data.Text.IO         as T
+import qualified Data.Time            as Time
+
+newtype AppM a = AppM (LoggingT IO a)
+  deriving (Functor, Applicative, Monad, MonadCatch, MonadThrow, MonadLogger, MonadIO)
+
+-- The tagless final interpreter.
+instance MonadNetwork AppM where
+  type Meta AppM = ()
+  recvMsg = Request <$> liftIO T.getLine <*> pure ()
+  putMsg Response{..} = liftIO . T.putStrLn $ content
+
+instance MonadData AppM where
+  putData key val = liftIO $ T.putStrLn $ "Would put " <> T.pack key <> " = " <> (T.pack $ show val)
+  getData key = liftIO (T.putStrLn $ "Would fetch " <> T.pack key) >> return Nothing
+
+instance MonadTime AppM where
+  getCurrentTime = liftIO Time.getCurrentTime
+
+runAppM :: AppM a -> IO a
+runAppM (AppM f) = runStdoutLoggingT f

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

src/Extension/Hello.hs

@@ -0,0 +1,15 @@
+{-# Language RecordWildCards #-}
+{-# Language OverloadedStrings #-}
+{-# Language ScopedTypeVariables #-}
+module Extension.Hello where
+
+import Bot.Extension
+import Bot.DSL
+import qualified Data.Text as T
+
+extension :: Extension ()
+extension = Extension{..}
+  where
+    name = "hello world"
+    act Request{..} | "hello" `T.isPrefixOf` content = return $ Just $ Response "Hello to you" ()
+                    | otherwise = return Nothing

src/Extensions.hs

@@ -0,0 +1,10 @@
+{-# LANGUAGE Safe #-}
+
+module Extensions where
+
+import           Bot.DSL
+import           Bot.Extension
+import qualified Extension.Hello as Hello
+
+extensions :: [Extension ()]
+extensions = [Hello.extension]

src/Main.hs

@@ -0,0 +1,9 @@
+module Main where
+
+import           AppM
+import           Bot.Lib
+import           Extensions
+
+
+main :: IO ()
+main = runAppM (mainLoop extensions)