{-# LANGUAGE TypeFamilies #-}
-- | Module: Poll
-- | Support for voting
-- |
-- | License: lGPL
-- |
-- | added by Kenneth Hoste (boegel), 22/11/2005
-- |  inspiration: Where plugin (thanks shapr,dons)
module Lambdabot.Plugin.Social.Poll (pollPlugin) where

import Lambdabot.Plugin
import qualified Data.ByteString.Char8 as P
import Data.List
import qualified Data.Map as M

newPoll :: Poll
newPoll :: Poll
newPoll = (Bool
True,[])

appendPoll :: Choice -> Poll -> (Maybe Poll)
appendPoll :: PollName -> Poll -> Maybe Poll
appendPoll PollName
choice (Bool
o,[(PollName, Count)]
ls) = forall a. a -> Maybe a
Just (Bool
o,(PollName
choice,Count
0)forall a. a -> [a] -> [a]
:[(PollName, Count)]
ls)

voteOnPoll :: Poll -> Choice -> (Poll,String)
voteOnPoll :: Poll -> PollName -> (Poll, String)
voteOnPoll (Bool
o,[(PollName, Count)]
poll) PollName
choice =
    if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(PollName
x,Count
_) -> PollName
x forall a. Eq a => a -> a -> Bool
== PollName
choice) [(PollName, Count)]
poll
        then ((Bool
o,forall a b. (a -> b) -> [a] -> [b]
map (\(PollName
c,Count
n) ->
                    if PollName
c forall a. Eq a => a -> a -> Bool
== PollName
choice then (PollName
c,Count
nforall a. Num a => a -> a -> a
+Count
1)
                                   else (PollName
c,Count
n)) [(PollName, Count)]
poll)
                                        ,String
"voted on " forall a. [a] -> [a] -> [a]
++ PollName -> String
pprChoice PollName
choice)
        else ((Bool
o,[(PollName, Count)]
poll),PollName -> String
pprChoice PollName
choice forall a. [a] -> [a] -> [a]
++ String
" is not currently a candidate in this poll")

------------------------------------------------------------------------

type Count             = Int
type Choice            = P.ByteString
type PollName          = P.ByteString
type Poll              = (Bool, [(Choice, Count)])
type VoteState         = M.Map PollName Poll
type VoteWriter        = VoteState -> Cmd Vote ()
type Vote              = ModuleT VoteState LB

------------------------------------------------------------------------
-- Define a serialiser

voteSerial :: Serial VoteState
voteSerial :: Serial VoteState
voteSerial = forall s.
(s -> Maybe PollName) -> (PollName -> Maybe s) -> Serial s
Serial (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Packable t => t -> PollName
showPacked) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Packable t => PollName -> t
readPacked)

------------------------------------------------------------------------

pollPlugin :: Module (M.Map PollName Poll)
pollPlugin :: Module VoteState
pollPlugin = forall st. Module st
newModule
    { moduleCmds :: ModuleT VoteState LB [Command Vote]
moduleCmds = forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"poll-list")
            { help :: Cmd Vote ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"poll-list                   Shows all current polls"
            , process :: String -> Cmd Vote ()
process = \String
_ -> do
                String
result <- forall (m :: * -> *) a.
MonadLBState m =>
(LBState m -> (LBState m -> m ()) -> m a) -> m a
withMS forall a b. (a -> b) -> a -> b
$ \LBState (Cmd Vote)
factFM LBState (Cmd Vote) -> Cmd Vote ()
writer -> VoteState -> VoteWriter -> String -> [PollName] -> Cmd Vote String
processCommand LBState (Cmd Vote)
factFM LBState (Cmd Vote) -> Cmd Vote ()
writer String
"poll-list" []
                forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
result
            }
        , (String -> Command Identity
command String
"poll-show")
            { help :: Cmd Vote ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"poll-show <poll>            Shows all choices for some poll"
            , process :: String -> Cmd Vote ()
process = String -> String -> Cmd Vote ()
process_ String
"poll-show"
            }
        , (String -> Command Identity
command String
"poll-add")
            { help :: Cmd Vote ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"poll-add <name>             Adds a new poll, with no candidates"
            , process :: String -> Cmd Vote ()
process = String -> String -> Cmd Vote ()
process_ String
"poll-add"
            }
        , (String -> Command Identity
command String
"choice-add")
            { help :: Cmd Vote ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"choice-add <poll> <choice>  Adds a new choice to the given poll"
            , process :: String -> Cmd Vote ()
process = String -> String -> Cmd Vote ()
process_ String
"choice-add"
            }
        , (String -> Command Identity
command String
"vote")
            -- todo, should @vote foo automagically add foo as a possibility?
            { help :: Cmd Vote ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"vote <poll> <choice>        Vote for <choice> in <poll>"
            , process :: String -> Cmd Vote ()
process = String -> String -> Cmd Vote ()
process_ String
"vote"
            }
        , (String -> Command Identity
command String
"poll-result")
            { help :: Cmd Vote ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"poll-result <poll>          Show result for given poll"
            , process :: String -> Cmd Vote ()
process = String -> String -> Cmd Vote ()
process_ String
"poll-result"
            }
        , (String -> Command Identity
command String
"poll-close")
            { help :: Cmd Vote ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"poll-close <poll>           Closes a poll"
            , process :: String -> Cmd Vote ()
process = String -> String -> Cmd Vote ()
process_ String
"poll-close"
            }
        , (String -> Command Identity
command String
"poll-remove")
            { help :: Cmd Vote ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"poll-remove <poll>          Removes a poll"
            , process :: String -> Cmd Vote ()
process = String -> String -> Cmd Vote ()
process_ String
"poll-remove"
            }
        , (String -> Command Identity
command String
"poll-reset")
            { help :: Cmd Vote ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"poll-reset <poll>           Resets votes and reopens a poll"
            , process :: String -> Cmd Vote ()
process = String -> String -> Cmd Vote ()
process_ String
"poll-reset"
            }
        ]

    , moduleDefState :: LB VoteState
moduleDefState  = forall (m :: * -> *) a. Monad m => a -> m a
return forall k a. Map k a
M.empty
    , moduleSerialize :: Maybe (Serial VoteState)
moduleSerialize = forall a. a -> Maybe a
Just Serial VoteState
voteSerial
    }

process_ :: [Char] -> [Char] -> Cmd Vote ()
process_ :: String -> String -> Cmd Vote ()
process_ String
cmd [] = forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String
"Missing argument. Check @help " forall a. [a] -> [a] -> [a]
++ String
cmd forall a. [a] -> [a] -> [a]
++ String
" for info.")
process_ String
cmd String
dat
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Char
c -> Char
c forall a. Ord a => a -> a -> Bool
< Char
' ' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'"') String
dat
    = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Please do not use control characters or double quotes in polls."
process_ String
cmd String
dat = do
    String
result <- forall (m :: * -> *) a.
MonadLBState m =>
(LBState m -> (LBState m -> m ()) -> m a) -> m a
withMS forall a b. (a -> b) -> a -> b
$ \LBState (Cmd Vote)
fm LBState (Cmd Vote) -> Cmd Vote ()
writer ->
        VoteState -> VoteWriter -> String -> [PollName] -> Cmd Vote String
processCommand LBState (Cmd Vote)
fm LBState (Cmd Vote) -> Cmd Vote ()
writer String
cmd (forall a b. (a -> b) -> [a] -> [b]
map String -> PollName
P.pack (String -> [String]
words String
dat))
    forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
result

------------------------------------------------------------------------

processCommand :: VoteState -> VoteWriter -> String -> [P.ByteString] -> Cmd Vote String
processCommand :: VoteState -> VoteWriter -> String -> [PollName] -> Cmd Vote String
processCommand VoteState
fm VoteWriter
writer String
cmd [PollName]
dat = case String
cmd of

    -- show all current polls
    String
"poll-list"  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ VoteState -> String
listPolls VoteState
fm

    -- show candidates
    String
"poll-show"    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [PollName]
dat of
                        [PollName
poll] -> VoteState -> PollName -> String
showPoll VoteState
fm PollName
poll
                        [PollName]
_ -> String
"usage: @poll-show <poll>"

    -- declare a new poll
    String
"poll-add"     -> case [PollName]
dat of
                        [PollName
poll] -> VoteState -> VoteWriter -> PollName -> Cmd Vote String
addPoll VoteState
fm VoteWriter
writer PollName
poll
                        [PollName]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return String
"usage: @poll-add <poll>   with \"ThisTopic\" style names"

    String
"choice-add"   -> case [PollName]
dat of
                        [PollName
poll,PollName
choice] -> VoteState -> VoteWriter -> PollName -> PollName -> Cmd Vote String
addChoice VoteState
fm VoteWriter
writer PollName
poll PollName
choice
                        [PollName]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return String
"usage: @choice-add <poll> <choice>"

    String
"vote"          -> case [PollName]
dat of
                        [PollName
poll,PollName
choice] -> VoteState -> VoteWriter -> PollName -> PollName -> Cmd Vote String
vote VoteState
fm VoteWriter
writer PollName
poll PollName
choice
                        [PollName]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return String
"usage: @vote <poll> <choice>"

    String
"poll-result"   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [PollName]
dat of
                        [PollName
poll] -> VoteState -> PollName -> String
showResult VoteState
fm PollName
poll
                        [PollName]
_ -> String
"usage: @poll-result <poll>"

    String
"poll-close"    -> case [PollName]
dat of
                        [PollName
poll] -> VoteState -> VoteWriter -> PollName -> Cmd Vote String
closePoll VoteState
fm VoteWriter
writer PollName
poll
                        [PollName]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return String
"usage: @poll-close <poll>"

    String
"poll-remove"   -> case [PollName]
dat of
                        [PollName
poll] -> VoteState -> VoteWriter -> PollName -> Cmd Vote String
removePoll VoteState
fm VoteWriter
writer PollName
poll
                        [PollName]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return String
"usage: @poll-remove <poll>"

    String
"poll-reset"    -> case [PollName]
dat of
                        [PollName
poll] -> VoteState -> VoteWriter -> PollName -> Cmd Vote String
resetPoll VoteState
fm VoteWriter
writer PollName
poll
                        [PollName]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return String
"usage: @poll-reset <poll>"
    String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return String
"Unknown command."

------------------------------------------------------------------------

listPolls :: VoteState -> String
listPolls :: VoteState -> String
listPolls VoteState
fm = forall a. (a -> String) -> [a] -> String
pprList PollName -> String
pprPoll forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall k a. Map k a -> [(k, a)]
M.toList VoteState
fm)

showPoll :: VoteState -> PollName -> String
showPoll :: VoteState -> PollName -> String
showPoll VoteState
fm PollName
poll =
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PollName
poll VoteState
fm of
        Maybe Poll
Nothing -> String
"No such poll: " forall a. [a] -> [a] -> [a]
++ PollName -> String
pprPoll PollName
poll forall a. [a] -> [a] -> [a]
++ String
" Use @poll-list to see the available polls."
        Just Poll
p  -> forall a. (a -> String) -> [a] -> String
pprList PollName -> String
pprChoice forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall a b. (a, b) -> b
snd Poll
p)

addPoll :: VoteState -> VoteWriter -> PollName -> Cmd Vote String
addPoll :: VoteState -> VoteWriter -> PollName -> Cmd Vote String
addPoll VoteState
fm VoteWriter
writer PollName
poll =
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PollName
poll VoteState
fm of
        Maybe Poll
Nothing -> do VoteWriter
writer forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PollName
poll Poll
newPoll VoteState
fm
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"Added new poll: " forall a. [a] -> [a] -> [a]
++ PollName -> String
pprPoll PollName
poll
        Just Poll
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"Poll " forall a. [a] -> [a] -> [a]
++ PollName -> String
pprPoll PollName
poll forall a. [a] -> [a] -> [a]
++
                            String
" already exists, choose another name for your poll"

addChoice :: VoteState -> VoteWriter -> PollName -> Choice -> Cmd Vote String
addChoice :: VoteState -> VoteWriter -> PollName -> PollName -> Cmd Vote String
addChoice VoteState
fm VoteWriter
writer PollName
poll PollName
choice = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PollName
poll VoteState
fm of
    Maybe Poll
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"No such poll: " forall a. [a] -> [a] -> [a]
++ PollName -> String
pprPoll PollName
poll
    Just Poll
_  -> do VoteWriter
writer forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
M.update (PollName -> Poll -> Maybe Poll
appendPoll PollName
choice) PollName
poll VoteState
fm
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"New candidate " forall a. [a] -> [a] -> [a]
++ PollName -> String
pprChoice PollName
choice forall a. [a] -> [a] -> [a]
++
                           String
", added to poll " forall a. [a] -> [a] -> [a]
++ PollName -> String
pprPoll PollName
poll forall a. [a] -> [a] -> [a]
++ String
"."

vote :: VoteState -> VoteWriter -> PollName -> Choice -> Cmd Vote String
vote :: VoteState -> VoteWriter -> PollName -> PollName -> Cmd Vote String
vote VoteState
fm VoteWriter
writer PollName
poll PollName
choice = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PollName
poll VoteState
fm of
    Maybe Poll
Nothing          -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"No such poll: " forall a. [a] -> [a] -> [a]
++ PollName -> String
pprPoll PollName
poll
    Just (Bool
False,[(PollName, Count)]
_)   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"The "forall a. [a] -> [a] -> [a]
++ PollName -> String
pprPoll PollName
poll forall a. [a] -> [a] -> [a]
++ String
" poll is closed, sorry !"
    Just p :: Poll
p@(Bool
True,[(PollName, Count)]
_)  -> do let (Poll
np,String
msg) = Poll -> PollName -> (Poll, String)
voteOnPoll Poll
p PollName
choice
                           VoteWriter
writer forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
M.update (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just Poll
np)) PollName
poll VoteState
fm
                           forall (m :: * -> *) a. Monad m => a -> m a
return String
msg

showResult :: VoteState -> PollName -> String
showResult :: VoteState -> PollName -> String
showResult VoteState
fm PollName
poll = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PollName
poll VoteState
fm of
    Maybe Poll
Nothing     -> String
"No such poll: "  forall a. [a] -> [a] -> [a]
++ PollName -> String
pprPoll PollName
poll
    Just (Bool
o,[(PollName, Count)]
p)  -> String
"Poll results for " forall a. [a] -> [a] -> [a]
++ PollName -> String
pprPoll PollName
poll forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ Bool -> String
status Bool
o forall a. [a] -> [a] -> [a]
++ String
"): "
                   forall a. [a] -> [a] -> [a]
++ (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse String
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Show a => (PollName, a) -> String
ppr [(PollName, Count)]
p)
        where
            status :: Bool -> String
status Bool
s | Bool
s         = String
"Open"
                     | Bool
otherwise = String
"Closed"
            ppr :: (PollName, a) -> String
ppr (PollName
x,a
y) = PollName -> String
pprChoice PollName
x forall a. [a] -> [a] -> [a]
++ String
"=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
y

removePoll :: VoteState -> VoteWriter -> PollName -> Cmd Vote String
removePoll :: VoteState -> VoteWriter -> PollName -> Cmd Vote String
removePoll VoteState
fm VoteWriter
writer PollName
poll = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PollName
poll VoteState
fm of
    Just (Bool
True,[(PollName, Count)]
_)  -> forall (m :: * -> *) a. Monad m => a -> m a
return String
"Poll should be closed before you can remove it."
    Just (Bool
False,[(PollName, Count)]
_) -> do VoteWriter
writer forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
M.delete PollName
poll VoteState
fm
                         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"poll " forall a. [a] -> [a] -> [a]
++ PollName -> String
pprPoll PollName
poll forall a. [a] -> [a] -> [a]
++ String
" removed."
    Maybe Poll
Nothing        -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"No such poll: " forall a. [a] -> [a] -> [a]
++ PollName -> String
pprPoll PollName
poll

closePoll :: VoteState -> VoteWriter -> PollName -> Cmd Vote String
closePoll :: VoteState -> VoteWriter -> PollName -> Cmd Vote String
closePoll VoteState
fm VoteWriter
writer PollName
poll = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PollName
poll VoteState
fm of
    Maybe Poll
Nothing     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"No such poll: " forall a. [a] -> [a] -> [a]
++ PollName -> String
pprPoll PollName
poll
    Just (Bool
_,[(PollName, Count)]
p)  -> do VoteWriter
writer forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
M.update (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just (Bool
False,[(PollName, Count)]
p))) PollName
poll VoteState
fm
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"Poll " forall a. [a] -> [a] -> [a]
++ PollName -> String
pprPoll PollName
poll forall a. [a] -> [a] -> [a]
++ String
" closed."

resetPoll :: VoteState -> VoteWriter -> PollName -> Cmd Vote String
resetPoll :: VoteState -> VoteWriter -> PollName -> Cmd Vote String
resetPoll VoteState
fm VoteWriter
writer PollName
poll = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PollName
poll VoteState
fm of
    Just (Bool
_, [(PollName, Count)]
vs)   -> do let np :: Poll
np = (Bool
True, forall a b. (a -> b) -> [a] -> [b]
map (\(PollName
c, Count
_) -> (PollName
c, Count
0)) [(PollName, Count)]
vs)
                         VoteWriter
writer forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
M.update (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just Poll
np)) PollName
poll VoteState
fm
                         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"Poll " forall a. [a] -> [a] -> [a]
++ PollName -> String
pprPoll PollName
poll forall a. [a] -> [a] -> [a]
++ String
" reset."
    Maybe Poll
Nothing        -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"No such poll: " forall a. [a] -> [a] -> [a]
++ PollName -> String
pprPoll PollName
poll

------------------------------------------------------------------------

-- we render strings verbatim but surround them with quotes,
-- relying on previous sanitization to disallow control characters
pprBS :: P.ByteString -> String
pprBS :: PollName -> String
pprBS PollName
p = String
"\"" forall a. [a] -> [a] -> [a]
++ PollName -> String
P.unpack PollName
p forall a. [a] -> [a] -> [a]
++ String
"\""

pprPoll :: PollName -> String
pprPoll :: PollName -> String
pprPoll = PollName -> String
pprBS

pprChoice :: Choice -> String
pprChoice :: PollName -> String
pprChoice = PollName -> String
pprBS

pprList :: (a -> String) -> [a] -> String
pprList :: forall a. (a -> String) -> [a] -> String
pprList a -> String
f [a]
as = String
"[" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse String
"," (forall a b. (a -> b) -> [a] -> [b]
map a -> String
f [a]
as)) forall a. [a] -> [a] -> [a]
++ String
"]"