{-# LANGUAGE TupleSections #-}
module Control.TriadCommittee where

import Control.Concurrent.STM
import Control.Monad
import Data.Maybe


data TriadSlot = SlotA | SlotB | SlotC
 deriving (Eq,Ord,Enum,Show,Read)

data TriadCommittee voter a = TriadCommittee
    { triadDecider :: TVar TriadSlot
    , triadA :: TVar (Maybe (voter,a))
    , triadB :: TVar (Maybe (voter,a))
    , triadC :: TVar (Maybe (voter,a))
    , triadNewDecision :: a -> STM ()
    }

triadSlot :: TriadSlot -> TriadCommittee voter a -> TVar (Maybe (voter,a))
triadSlot SlotA = triadA
triadSlot SlotB = triadB
triadSlot SlotC = triadC

triadDecision :: a -> TriadCommittee voter a -> STM a
triadDecision fallback triad = do
    slot <- readTVar (triadDecider triad)
    maybe fallback snd <$> readTVar (triadSlot slot triad)


newTriadCommittee :: (a -> STM ()) -> STM (TriadCommittee voter a)
newTriadCommittee onChange =
    TriadCommittee <$> newTVar SlotA
                   <*> newTVar Nothing
                   <*> newTVar Nothing
                   <*> newTVar Nothing
                   <*> pure onChange


triadCountVotes :: Eq a => Maybe a -> TriadCommittee voter a -> STM ()
triadCountVotes prior triad = do
    a <- fmap ((SlotA,) . snd) <$> readTVar (triadA triad)
    b <- fmap ((SlotB,) . snd) <$> readTVar (triadB triad)
    c <- fmap ((SlotC,) . snd) <$> readTVar (triadC triad)
    let (slot,vote) = case catMaybes [a,b,c] of
            [  (x,xvote)
             , (y,yvote)
             , (z,zvote) ]  -> if xvote == yvote then (x,Just xvote)
                                                 else (z,Just zvote)
            []              -> (SlotA,Nothing)
            ((slot,vote):_) -> (slot, Just vote)
    writeTVar (triadDecider triad) slot
    case vote of
        Just v | vote /= prior -> triadNewDecision triad v
        _                      -> return ()


addVote :: (Eq voter, Eq a) => TriadCommittee voter a -> voter -> a -> STM ()
addVote triad voter vote = do
    a <- (SlotA,) . fmap fst <$> readTVar (triadA triad)
    b <- (SlotB,) . fmap fst <$> readTVar (triadB triad)
    c <- (SlotC,) . fmap fst <$> readTVar (triadC triad)
    let avail (_,Nothing) = True
        avail (_,Just x ) = (x == voter)
        slots = filter avail [a,b,c]
    forM_ (take 1 slots) $ \(slot,_) -> do
        prior <- do
            slotp <- readTVar (triadDecider triad)
            fmap snd <$> readTVar (triadSlot slotp triad)
        writeTVar (triadSlot slot triad)
                  (Just (voter,vote))
        triadCountVotes prior triad


delVote :: (Eq voter, Eq a) => TriadCommittee voter a -> voter -> STM ()
delVote triad voter = do
    a <- (SlotA,) . fmap fst <$> readTVar (triadA triad)
    b <- (SlotB,) . fmap fst <$> readTVar (triadB triad)
    c <- (SlotC,) . fmap fst <$> readTVar (triadC triad)
    let match (_,Just x ) = (x == voter)
        match _           = False
        slots = filter match [a,b,c]
    forM_ (take 1 slots) $ \(slot,_) -> do
        prior <- do
            slotp <- readTVar (triadDecider triad)
            fmap snd <$> readTVar (triadSlot slotp triad)
        writeTVar (triadSlot slot triad) Nothing
        triadCountVotes prior triad