A simple dice rolling bot based on `pipes-irc'. Responds to commands like "roll d20+d4+3"

Dice.hs

{-# LANGUAGE OverloadedStrings #-}
import           Control.Monad
import           Control.Monad.Identity
import           Control.Monad.Random
import qualified Data.ByteString                        as BS
import qualified Data.ByteString.Char8                  as B
import           Data.Maybe
import           Data.Set                               as S
import           Data.Traversable                       as T
import           Pipes
import           Pipes.Network.IRC
import           Text.Parsec
import           Text.Parsec.Expr
import qualified Text.Parsec.Token                      as Tok
import           Text.ParserCombinators.Parsec.Language

main = runIrc defSettings {hook = myHook, trigger = "roll "}

p :: MonadIO m => BS.ByteString -> Pipe Message Command m r
p name = do
  msg <- await
  case msgCommand msg of
    PrivMsgCmd targets txt -> do
      liftIO $ print txt
      r <- liftIO $ runRoll (BS.drop 5 txt) ""
      -- when (B.isPrefixOf "roll d" txt) $ do
      --   r <- liftIO . T.sequence $ case B.splitAt 6 txt of
      --   (_,n) -> fmap (roll . fst) (B.readInteger n)
      yield $ PrivMsgCmd (name `S.delete` targets) r
      p name
    _ -> p name

runRoll :: BS.ByteString -> String -> IO BS.ByteString
runRoll s from =
  case parse expr from s of
   Left err -> return (B.pack (show err))
   Right r  -> fmap (B.pack . show) $ evalRandIO (evalRoll r)

die :: (RandomGen g) => Integer -> Rand g Integer
die n = getRandomR (1,n)

myHook :: MsgHook
myHook s = p (nick s)

data Roll =
    DieRoll Roll
  | Literal Integer
  | Add Roll Roll
  deriving (Show)

evalRoll :: RandomGen g => Roll -> Rand g Integer
evalRoll (Literal n) = return n
evalRoll (DieRoll r) = evalRoll r >>= die
evalRoll (Add r1 r2) = liftM2 (+) (evalRoll r1) (evalRoll r2)

langDef :: GenLanguageDef BS.ByteString () Identity
langDef = emptyDef { Tok.commentStart   = "/*"
                   , Tok.commentEnd     = "*/"
                   , Tok.commentLine    = "//"
                   , Tok.nestedComments = False
                   , Tok.identStart     = letter <|> char '_'
                   , Tok.identLetter    = alphaNum <|> oneOf "_'"
                   , Tok.opStart        = oneOf ":!#$%&*+./<=>?@\\^|-~"
                   , Tok.opLetter       = oneOf ":!#$%&*+./<=>?@\\^|-~"
                   , Tok.reservedOpNames= ["+", "d"]
                   , Tok.reservedNames  = []
                   , Tok.caseSensitive  = True
                   }

lexem :: Tok.GenTokenParser BS.ByteString () Identity
lexem = Tok.makeTokenParser langDef
natural = Tok.natural lexem
parens = Tok.parens lexem

expr :: Parsec BS.ByteString () Roll
expr = buildExpressionParser table term
    <?> "expression"

term :: Parsec BS.ByteString () Roll
term =  parens expr
    <|> liftM Literal natural
    <?> "term"

table :: OperatorTable BS.ByteString () Identity Roll
table   = [ [prefix "d" DieRoll]
          , [binary "+" Add AssocLeft]
          ]

binary  name fun assoc = Infix (do{ Tok.reservedOp lexem name; return fun }) assoc
prefix  name fun       = Prefix (do{ Tok.reservedOp lexem name; return fun })