telegram-bot-simple-0.14.4: examples/TodoBot.hs

{-# LANGUAGE OverloadedStrings #-}
module Main where

import Control.Applicative
import Data.Text (Text)
import qualified Data.Text as Text
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap

import Telegram.Bot.API
import Telegram.Bot.Simple
import Telegram.Bot.Simple.UpdateParser

type Item = Text

data Model = Model
  { todoLists   :: HashMap Text [Item]
  , currentList :: Text
  }

defaultListName :: Text
defaultListName = "Default"

initialModel :: Model
initialModel = Model
  { todoLists = HashMap.fromList [(defaultListName, [])]
  , currentList = defaultListName
  }

data Action
  =  Start
  | AddItem Item
  | RemoveItem Item
  | SwitchToList Text
  | ShowAll
  | Show Text
  deriving (Show, Read)

todoBot3 :: BotApp Model Action
todoBot3 = BotApp
  { botInitialModel = initialModel
  , botAction = flip updateToAction
  , botHandler = handleAction
  , botJobs = []
  }
  where
    updateToAction :: Model -> Update -> Maybe Action
    updateToAction _ = parseUpdate $
          AddItem      <$> plainText
      <|> Start        <$  command "start"
      <|> AddItem      <$> command "add"
      <|> RemoveItem   <$> command "remove"
      <|> SwitchToList <$> command "switch_to_list"
      <|> Show         <$> command "show"
      <|> ShowAll      <$  command "show_all"
      <|> callbackQueryDataRead

    handleAction :: Action -> Model -> Eff Action Model
    handleAction action model = case action of
      Start -> model <# do
        reply (toReplyMessage startMessage)
          { replyMessageReplyMarkup = Just (SomeReplyKeyboardMarkup startKeyboard) }
      AddItem item -> addItem item model <# do
        replyText "Ok, got it!"
      RemoveItem item -> removeItem item model <# do
        replyText "Item removed!"  
      SwitchToList name -> model { currentList = name } <# do
        replyText ("Switched to list «" <> name <> "»!") 
      ShowAll -> model <# do
        reply (toReplyMessage "Available todo lists")
          { replyMessageReplyMarkup = Just (SomeInlineKeyboardMarkup listsKeyboard) }
      Show "" -> model <# do
        return (Show defaultListName)
      Show name -> model <# do
        let items = concat (HashMap.lookup name (todoLists model))
        if null items
          then reply (toReplyMessage ("The list «" <> name <> "» is empty. Maybe try these starter options?"))
                 { replyMessageReplyMarkup = Just (SomeReplyKeyboardMarkup startKeyboard) }
          else replyText (Text.unlines items)

      where
        listsKeyboard = InlineKeyboardMarkup
          (map (\name -> [actionButton name (Show name)]) (HashMap.keys (todoLists model)))

    startMessage = Text.unlines
      [ "Hello! I am your personal TODO bot :)"
      , ""
      , "You can add new items to your todo list just by typing it!"
      , "You can also use /add command to do that explicitely."
      , "To remove an item use /remove command."
      , ""
      , "You can manage multiple todo lists:"
      , "Switch to a new named list with /switch_to_list <list>."
      , "Show all available lists with /show_all."
      , "Show items for a specific list with /show <list>."
      , ""
      , "Here are some starter options, try adding something to the list."
      ]

    startKeyboard :: ReplyKeyboardMarkup
    startKeyboard = ReplyKeyboardMarkup
      { replyKeyboardMarkupKeyboard =
          [ [ "Buy milk", "Get job done" ]
          , [ "Build a house", "Plant a tree" ]
          ]
      , replyKeyboardMarkupResizeKeyboard = Just True
      , replyKeyboardMarkupOneTimeKeyboard = Just True
      , replyKeyboardMarkupSelective = Nothing
      , replyKeyboardMarkupInputFieldSelector = Nothing
      , replyKeyboardMarkupIsPersistent = Nothing
      }

addItem :: Item -> Model -> Model
addItem item model = model
  { todoLists = HashMap.insertWith (++) (currentList model) [item] (todoLists model) }

removeItem :: Item -> Model -> Model
removeItem item model = model
  { todoLists = HashMap.adjust (filter (/= item)) (currentList model) (todoLists model)}

run :: Token -> IO ()
run token = do
  env <- defaultTelegramClientEnv token
  startBot_ (conversationBot updateChatId todoBot3) env

main :: IO ()
main = do
  putStrLn "Please, enter Telegram bot's API token:"
  token <- Token . Text.pack <$> getLine
  run token