Skip to content

Instantly share code, notes, and snippets.

@co-dan co-dan/Dice.hs
Created Feb 22, 2015

Embed
What would you like to do?
A simple dice rolling bot based on `pipes-irc'. Responds to commands like "roll d20+d4+3"
{-# 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 })
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.