{-# LANGUAGE DeriveDataTypeable, GADTs, ScopedTypeVariables, TupleSections, TemplateHaskell#-}

-- | All the building blocks to build rules and basic rules examples.
module Language.Nomyx.Rule where

import Language.Nomyx.Expression
import Data.Typeable
import Control.Monad.State
import Data.List
import Data.Maybe
import Data.Time hiding (getCurrentTime)
import Data.Function
import Data.Map hiding (map, filter, insert, mapMaybe)
import qualified Data.Map as M (map, insert)
import System.Locale (defaultTimeLocale, rfc822DateFormat)
import Control.Arrow
import Data.Time.Recurrence hiding (filter)
import Safe
import Control.Applicative


-- * Variables
-- | variable creation
newVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Exp (Maybe (V a))
newVar = NewVar

newVar_ :: (Typeable a, Show a, Eq a) => VarName -> a -> Exp (V a)
newVar_ s a = do
    mv <- NewVar s a
    case mv of
        Just var -> return var
        Nothing -> error "newVar_: Variable existing"

-- | variable reading
readVar :: (Typeable a, Show a, Eq a) => (V a) -> Exp (Maybe a)
readVar = ReadVar

readVar_ :: forall a. (Typeable a, Show a, Eq a) => (V a) -> Exp a
readVar_ v@(V a) = do
    ma <- ReadVar v
    case ma of
        Just (val:: a) -> return val
        Nothing -> error $ "readVar_: Variable \"" ++ a ++ "\" with type \"" ++ (show $ typeOf v) ++ "\" not existing"

-- | variable writing
writeVar :: (Typeable a, Show a, Eq a) => (V a) -> a -> Exp Bool
writeVar = WriteVar

writeVar_ :: (Typeable a, Show a, Eq a) => (V a) -> a -> Exp ()
writeVar_ var val = do
    ma <- WriteVar var val
    case ma of
       True -> return ()
       False -> error "writeVar_: Variable not existing"

-- | modify a variable using the provided function
modifyVar :: (Typeable a, Show a, Eq a) => (V a) -> (a -> a) -> Exp ()
modifyVar v f = writeVar_ v . f =<< readVar_ v

-- | delete variable
delVar :: (V a) -> Exp Bool
delVar = DelVar

delVar_ :: (V a) -> Exp ()
delVar_ v = DelVar v >> return ()

-- * Variable arrays
-- | ArrayVar is an indexed array with a signal attached to warn when the array is filled.
--each indexed elements starts empty (value=Nothing), and when the array is full, the signal is triggered.
--This is useful to wait for a serie of events to happen, and trigger a computation on the collected results.
data ArrayVar i a = ArrayVar (Event (Message [(i, a)])) (V (Map i (Maybe a)))

-- | initialize an empty ArrayVar
newArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> Exp (ArrayVar i a)
newArrayVar name l = do
    let list = map (\i -> (i, Nothing)) l
    v <- newVar_ name (fromList list)
    return $ ArrayVar (Message name) v

-- | initialize an empty ArrayVar, registering a callback that will be triggered when the array is filled
newArrayVar' :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> ([(i,a)] -> Exp ()) -> Exp (ArrayVar i a)
newArrayVar' name l f = do
    av@(ArrayVar m v) <- newArrayVar name l
    onMessage m $ f . messageData
    return av

-- | initialize an empty ArrayVar, registering a callback.
--the callback will be triggered when the array is filled, and then the ArrayVar will be deleted
newArrayVarOnce :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> ([(i,a)] -> Exp ()) -> Exp (ArrayVar i a)
newArrayVarOnce name l f = do
    av@(ArrayVar m v) <- newArrayVar name l
    onMessageOnce m (\a -> (f $ messageData a) >> (delVar_ v))
    return av

-- | store one value and the given index. If this is the last filled element, the registered callbacks are triggered.
putArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> i -> a -> Exp ()
putArrayVar (ArrayVar m v) i a = do
    ar <- readVar_ v
    let ar2 = M.insert i (Just a) ar
    writeVar_ v ar2
    let finish = and $ map isJust $ elems ar2
    when finish $ sendMessage m (toList $ M.map fromJust ar2)

-- | get the messsage triggered when the array is filled
getArrayVarMessage :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Exp (Event (Message [(i, a)]))
getArrayVarMessage (ArrayVar m _) = return m

-- | get the association array
getArrayVarData :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Exp ([(i, Maybe a)])
getArrayVarData (ArrayVar _ v) = toList <$> (readVar_ v)

-- | get the association array with only the filled values
getArrayVarData' :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Exp ([(i, a)])
getArrayVarData' v = catMaybes . map sndMaybe <$> (getArrayVarData v)

delArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Exp ()
delArrayVar (ArrayVar m v) = delAllEvents m >> delVar_ v

-- * Events

-- | register a callback on an event
onEvent :: (Typeable e, Show e, Eq e) => Event e -> ((EventNumber, EventData e) -> Exp ()) -> Exp EventNumber
onEvent = OnEvent

-- | register a callback on an event, disregard the event number
onEvent_ :: forall e. (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Exp ()) -> Exp ()
onEvent_ e h = do
    OnEvent e (\(_, d) -> h d)
    return ()

-- | set an handler for an event that will be triggered only once
onEventOnce :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Exp ()) -> Exp EventNumber
onEventOnce e h = do
    let handler (en, ed) = delEvent_ en >> h ed
    n <- OnEvent e handler
    return n

-- | set an handler for an event that will be triggered only once
onEventOnce_ :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Exp ()) -> Exp ()
onEventOnce_ e h = do
    let handler (en, ed) = delEvent_ en >> h ed
    OnEvent e handler
    return ()

delEvent :: EventNumber -> Exp Bool
delEvent = DelEvent

delEvent_ :: EventNumber -> Exp ()
delEvent_ e = delEvent e >> return ()

delAllEvents :: (Typeable e, Show e, Eq e) => Event e -> Exp ()
delAllEvents = DelAllEvents

-- | broadcast a message that can be catched by another rule
sendMessage :: (Typeable a, Show a, Eq a) => Event (Message a) -> a -> Exp ()
sendMessage = SendMessage

sendMessage_ :: Event (Message ()) -> Exp ()
sendMessage_ m = SendMessage m ()

-- | subscribe on a message 
onMessage :: (Typeable m, Show m) => Event (Message m) -> ((EventData (Message m)) -> Exp ()) -> Exp ()
onMessage m f = onEvent_ m f

onMessageOnce :: (Typeable m, Show m) => Event (Message m) -> ((EventData (Message m)) -> Exp ()) -> Exp ()
onMessageOnce m f = onEventOnce_ m f

-- | on the provided schedule, the supplied function will be called
schedule :: (Schedule Freq) -> (UTCTime -> Exp ()) -> Exp ()
schedule sched f = do
    now <- getCurrentTime
    let next = head $ starting now $ sched
    if (next == now) then executeAndScheduleNext (f . timeData) sched (TimeData now)
                     else onEventOnce_ (Time next) $ executeAndScheduleNext (f . timeData) sched where

executeAndScheduleNext :: (EventData Time -> Exp ()) -> (Schedule Freq) -> (EventData Time) -> Exp ()
executeAndScheduleNext f sched now = do
   f now
   let rest = drop 1 $ starting (timeData now) $ sched
   when (rest /= []) $ onEventOnce_ (Time $ head rest) $ executeAndScheduleNext f sched


schedule_ :: (Schedule Freq) -> Exp () -> Exp ()
schedule_ ts f = schedule ts (\_-> f)

--at each time provided, the supplied function will be called
schedule' :: [UTCTime] -> (UTCTime -> Exp ()) -> Exp ()
schedule' sched f = do
    let sched' = sort sched
    now <- getCurrentTime
    let nextMay = headMay $ filter (>=now) $ sched'
    case nextMay of
        Just next -> do
           if (next == now) then executeAndScheduleNext' (f . timeData) sched' (TimeData now)
                     else onEventOnce_ (Time next) $ executeAndScheduleNext' (f . timeData) sched'
        Nothing -> return ()
            

executeAndScheduleNext' :: (EventData Time -> Exp ()) -> [UTCTime] -> (EventData Time) -> Exp ()
executeAndScheduleNext' f sched now = do
   f now
   let rest = drop 1 $ sched
   when (rest /= []) $ onEventOnce_ (Time $ head rest) $ executeAndScheduleNext' f sched
   

schedule'_ :: [UTCTime] -> Exp () -> Exp ()
schedule'_ ts f = schedule' ts (\_-> f)

-- * Rule management

-- | activate a rule: change its state to Active and execute it
activateRule :: RuleNumber -> Exp Bool
activateRule = ActivateRule

activateRule_ :: RuleNumber -> Exp ()
activateRule_ r = activateRule r >> return ()

-- | reject a rule: change its state to Suppressed and suppresses all its environment (events, variables, inputs)
-- the rule can be activated again later
rejectRule :: RuleNumber -> Exp Bool
rejectRule = RejectRule

rejectRule_ :: RuleNumber -> Exp ()
rejectRule_ r = rejectRule r >> return ()

getRules :: Exp [Rule]
getRules = GetRules

getActiveRules :: Exp [Rule]
getActiveRules = return . (filter ((== Active) . rStatus) ) =<< getRules

getRule :: RuleNumber -> Exp (Maybe Rule)
getRule rn = do
   rs <- GetRules
   return $ find (\(Rule {rNumber = n}) -> n == rn) rs

getRulesByNumbers :: [RuleNumber] -> Exp [Rule]
getRulesByNumbers rns = mapMaybeM getRule rns

getRuleFuncs :: Exp [RuleFunc]
getRuleFuncs = return . (map rRuleFunc) =<< getRules

-- | add a rule to the game, it will have to be activated 
addRule :: Rule -> Exp Bool
addRule r = AddRule r

addRule_ :: Rule -> Exp ()
addRule_ r = AddRule r >> return ()

addRuleParams_ :: RuleName -> RuleFunc -> RuleCode -> RuleNumber -> String -> Exp ()
addRuleParams_ name func code number desc = addRule_ $ defaultRule {rName = name, rRuleFunc = func, rRuleCode = code, rNumber = number, rDescription = desc}

--suppresses completly a rule and its environment from the system
suppressRule :: RuleNumber -> Exp Bool
suppressRule rn = DelRule rn

suppressRule_ :: RuleNumber -> Exp ()
suppressRule_ rn = DelRule rn >> return ()

suppressAllRules :: Exp Bool
suppressAllRules = do
    rs <- getRules
    res <- mapM (suppressRule . rNumber) rs
    return $ and res

modifyRule :: RuleNumber -> Rule -> Exp Bool
modifyRule rn r = ModifyRule rn r


-- * Inputs

inputChoice :: (Eq c, Show c) => PlayerNumber -> String -> [c] -> c -> Event (InputChoice c)
inputChoice = InputChoice

inputChoiceHead :: (Eq c, Show c) => PlayerNumber -> String -> [c] -> Event (InputChoice c)
inputChoiceHead pn title choices = inputChoice pn title choices (head choices)

inputChoiceEnum :: forall c. (Enum c, Bounded c, Typeable c, Eq c,  Show c) => PlayerNumber -> String -> c -> Event (InputChoice c)
inputChoiceEnum pn title defaultChoice = inputChoice pn title (enumFrom (minBound::c)) defaultChoice

inputString :: PlayerNumber -> String -> Event InputString
inputString = InputString

-- | triggers a choice input to the user. The result will be sent to the callback
onInputChoice :: (Typeable a, Eq a,  Show a) => String -> [a] -> (EventNumber -> a -> Exp ()) -> PlayerNumber -> Exp EventNumber
onInputChoice title choices handler pn = onEvent (inputChoiceHead pn title choices) (\(en, a) -> handler en (inputChoiceData a))

-- | the same, disregard the event number
onInputChoice_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Exp ()) -> PlayerNumber -> Exp ()
onInputChoice_ title choices handler pn = onEvent_ (inputChoiceHead pn title choices) (handler . inputChoiceData)

-- | the same, suppress the event after first trigger
onInputChoiceOnce :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Exp ()) -> PlayerNumber -> Exp EventNumber
onInputChoiceOnce title choices handler pn = onEventOnce (inputChoiceHead pn title choices) (handler . inputChoiceData)

-- | the same, disregard the event number
onInputChoiceOnce_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Exp ()) -> PlayerNumber -> Exp ()
onInputChoiceOnce_ title choices handler pn = onEventOnce_ (inputChoiceHead pn title choices) (handler . inputChoiceData)

-- | triggers a choice input to the user, using an enumerate as input
onInputChoiceEnum :: forall a. (Enum a, Bounded a, Typeable a, Eq a,  Show a) => String -> a -> (EventNumber -> a -> Exp ()) -> PlayerNumber -> Exp EventNumber
onInputChoiceEnum title defaultChoice handler pn = onEvent (inputChoiceEnum pn title defaultChoice) (\(en, a) -> handler en (inputChoiceData a))

-- | the same, disregard the event number
onInputChoiceEnum_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a,  Show a) => String -> a -> (a -> Exp ()) -> PlayerNumber -> Exp ()
onInputChoiceEnum_ title defaultChoice handler pn = onEvent_ (inputChoiceEnum pn title defaultChoice) (handler . inputChoiceData)

-- | the same, suppress the event after first trigger
onInputChoiceEnumOnce_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a,  Show a) => String -> a -> (a -> Exp ()) -> PlayerNumber -> Exp ()
onInputChoiceEnumOnce_ title defaultChoice handler pn = onEventOnce_ (inputChoiceEnum pn title defaultChoice) (handler . inputChoiceData)


-- | triggers a string input to the user. The result will be sent to the callback
onInputString :: String -> (EventNumber -> String -> Exp ()) -> PlayerNumber -> Exp EventNumber
onInputString title handler pn = onEvent (inputString pn title) (\(en, a) -> handler en (inputStringData a))

-- | asks the player pn to answer a question, and feed the callback with this data.
onInputString_ :: String -> (String -> Exp ()) -> PlayerNumber -> Exp ()
onInputString_ title handler pn = onEvent_ (inputString pn title) (handler . inputStringData)

-- | asks the player pn to answer a question, and feed the callback with this data.
onInputStringOnce_ :: String -> (String -> Exp ()) -> PlayerNumber -> Exp ()
onInputStringOnce_ title handler pn = onEventOnce_ (inputString pn title) (handler . inputStringData)


-- * Victory, players, output, time and self-number

-- | set victory to a list of players
setVictory :: [PlayerNumber] -> Exp ()
setVictory = SetVictory

-- | give victory to one player
giveVictory :: PlayerNumber -> Exp ()
giveVictory pn = SetVictory [pn]

getPlayers :: Exp [PlayerInfo]
getPlayers = GetPlayers

-- | Get the total number of players
getPlayersNumber :: Exp Int
getPlayersNumber = length <$> getPlayers

getAllPlayerNumbers :: Exp [PlayerNumber]
getAllPlayerNumbers = map playerNumber <$> getPlayers


-- | outputs a message to one player
output :: String -> PlayerNumber -> Exp ()
output s pn = Output pn s

outputAll :: String -> Exp ()
outputAll s = getPlayers >>= mapM_ ((output s) . playerNumber)

getCurrentTime :: Exp UTCTime
getCurrentTime = CurrentTime

-- | allows a rule to retrieve its self number (for auto-deleting for example)
getSelfRuleNumber :: Exp RuleNumber
getSelfRuleNumber = SelfRuleNumber

getSelfRule :: Exp Rule
getSelfRule  = do
   srn <- getSelfRuleNumber
   rs:[] <- getRulesByNumbers [srn]
   return rs

getSelfProposedByPlayer :: Exp PlayerNumber
getSelfProposedByPlayer = getSelfRule >>= return . rProposedBy

-- * Rule samples

-- | This rule will activate automatically any new rule.
autoActivate :: RuleFunc
autoActivate = VoidRule $ onEvent_ (RuleEv Proposed) (activateRule_ . rNumber . ruleData)

-- | This rule will forbid any new rule to delete the rule in parameter
immutableRule :: RuleNumber -> RuleFunc
immutableRule rn = RuleRule f where
   f r = do
      protectedRule <- getRule rn
      case protectedRule of
         Just pr -> case rRuleFunc r of
            RuleRule paramRule -> paramRule pr
            otherwise -> return $ BoolResp True
         Nothing -> return $ BoolResp True

-- | A rule will be always legal
legal :: RuleFunc
legal = RuleRule $ \_ -> return $ BoolResp True

-- | A rule will be always illegal
illegal :: RuleFunc
illegal = RuleRule $ \_ -> return $ BoolResp False

-- | This rule establishes a list of criteria rules that will be used to test any incoming rule
-- the rules applyed shall give the answer immediatly
simpleApplicationRule :: RuleFunc
simpleApplicationRule = VoidRule $ do
    v <- newVar_ "rules" ([]:: [RuleNumber])
    onEvent_ (RuleEv Proposed) (h v) where
        h v (RuleData rule) = do
            (rns:: [RuleNumber]) <- readVar_ v
            rs <- getRulesByNumbers rns
            oks <- mapM (applyRule rule) rs
            when (and oks) $ activateRule_ $ rNumber rule

applyRule :: Rule -> Rule -> Exp Bool
applyRule (Rule {rRuleFunc = rf}) r = do
    case rf of
        RuleRule f1 -> f1 r >>= return . boolResp
        otherwise -> return False

        
-- | active metarules are automatically used to evaluate a given rule
checkWithMetarules :: Rule -> Exp RuleResponse
checkWithMetarules r = do
    rs <- getActiveRules
    let rrs = mapMaybe maybeMetaRule rs
    evals <- mapM (\rr -> rr r) rrs
    andrrs evals


maybeMetaRule :: Rule -> Maybe (OneParamRule Rule)
maybeMetaRule Rule {rRuleFunc = (RuleRule r)} = Just r
maybeMetaRule _ = Nothing


-- | any new rule will be activate if all active meta rules returns True
onRuleProposed :: (Rule -> Exp RuleResponse) -> RuleFunc
onRuleProposed r = VoidRule $ onEvent_ (RuleEv Proposed) $ \(RuleData rule) -> do
    resp <- r rule
    case resp of
        BoolResp b -> activateOrReject rule b
        MsgResp m -> onMessageOnce m $ (activateOrReject rule) . messageData



data ForAgainst = For | Against deriving (Typeable, Enum, Show, Eq, Bounded, Read)

-- | rule that performs a vote for a rule on all players. The provided function is used to count the votes.
voteWith :: ([(PlayerNumber, ForAgainst)] -> Bool) -> Rule -> Exp RuleResponse
voteWith f rule = do
    pns <- getAllPlayerNumbers
    let rn = show $ rNumber rule
    let m = Message ("Unanimity for " ++ rn)
    --create an array variable to store the votes. A message with the result of the vote is sent upon completion
    voteVar <- newArrayVarOnce ("Votes for " ++ rn) pns (sendMessage m . f)
    --create inputs to allow every player to vote and store the results in the array variable
    let askPlayer pn = onInputChoiceOnce_ ("Vote for rule " ++ rn) [For, Against] (putArrayVar voteVar pn) pn
    mapM_ askPlayer pns
    return $ MsgResp m

-- | assess the vote results according to a unanimity
unanimity :: [(PlayerNumber, ForAgainst)] -> Bool
unanimity l = ((length $ filter ((== Against) . snd) l) == 0)

-- | assess the vote results according to an absolute majority (half participants plus one)
majority :: [(PlayerNumber, ForAgainst)] -> Bool
majority l = ((length $ filter ((== For) . snd) l) >= (length l) `div` 2 + 1)

activateOrReject :: Rule -> Bool -> Exp ()
activateOrReject r b = if b then activateRule_ (rNumber r) else rejectRule_ (rNumber r)

-- | rule that performs a vote for a rule on all players. The provided function is used to count the votes,
--it will be called when every players has voted or when the time limit is reached
voteWithTimeLimit :: ([(PlayerNumber, ForAgainst)] -> Bool) -> UTCTime -> RuleFunc
voteWithTimeLimit f t = RuleRule $ \rule -> do
    pns <- getAllPlayerNumbers
    let rn = show $ rNumber rule
    let m = Message ("Unanimity for " ++ rn)
    --create an array variable to store the votes. A message with the result of the vote is sent upon completion
    voteVar <- newArrayVarOnce ("Votes for " ++ rn) pns (sendMessage m . f)
    --create inputs to allow every player to vote and store the results in the array variable
    let askPlayer pn = onInputChoiceOnce ("Vote for rule " ++ rn) [For, Against] (putArrayVar voteVar pn) pn
    ics <- mapM askPlayer pns
    --time limit
    onEventOnce_ (Time t) $ \_ -> do
        getArrayVarData' voteVar >>= sendMessage m . f
        delArrayVar voteVar
        mapM_ delEvent ics
    return $ MsgResp m

-- | perform an action for each current players, new players and leaving players
forEachPlayer :: (PlayerNumber -> Exp ()) -> (PlayerNumber -> Exp ()) -> (PlayerNumber -> Exp ()) -> Exp ()
forEachPlayer action actionWhenArrive actionWhenLeave = do
    pns <- getAllPlayerNumbers
    mapM_ action pns
    onEvent_ (Player Arrive) $ \(PlayerData p) -> actionWhenArrive $ playerNumber p
    onEvent_ (Player Leave) $ \(PlayerData p) -> actionWhenLeave $ playerNumber p

-- | perform the same action for each players, including new players
forEachPlayer_ :: (PlayerNumber -> Exp ()) -> Exp ()
forEachPlayer_ action = forEachPlayer action action (\_ -> return ())

forEachPlayer' :: (PlayerNumber -> Exp a) -> ((PlayerNumber, a) -> Exp ()) -> Exp ()
forEachPlayer' = undefined

-- | create a value initialized for each players
--manages players joining and leaving
createValueForEachPlayer :: Int -> V [(Int, Int)] -> Exp ()
createValueForEachPlayer initialValue var = do
    pns <- getAllPlayerNumbers
    v <- newVar_ (varName var) $ map (,initialValue::Int) pns
    forEachPlayer (\_-> return ())
                  (\p -> modifyVar v ((p, initialValue):))
                  (\p -> modifyVar v $ filter $ (/= p) . fst)

-- | create a value initialized for each players initialized to zero
--manages players joining and leaving
createValueForEachPlayer_ :: V [(Int, Int)] -> Exp ()
createValueForEachPlayer_ = createValueForEachPlayer 0

modifyValueOfPlayer :: PlayerNumber -> V [(Int, Int)] -> (Int -> Int) -> Exp ()
modifyValueOfPlayer pn var f = modifyVar var $ map $ (\(a,b) -> if a == pn then (a, f b) else (a,b))

modifyAllValues :: V [(Int, Int)] -> (Int -> Int) -> Exp ()
modifyAllValues var f = modifyVar var $ map $ second f

-- | Player p cannot propose anymore rules
noPlayPlayer :: PlayerNumber -> RuleFunc
noPlayPlayer p = RuleRule $ \r -> return $ BoolResp $ (rProposedBy r) /= p

-- | a rule can autodelete itself (generaly after having performed some actions)
autoDelete :: Exp ()
autoDelete = getSelfRuleNumber >>= suppressRule_


-- | All rules from player p are erased:
eraseAllRules :: PlayerNumber -> Exp Bool
eraseAllRules p = do
    rs <- getRules
    let myrs = filter (\r ->  (rProposedBy r) == p) rs
    res <- mapM (suppressRule . rNumber) myrs
    return $ and res

-- * Miscellaneous

mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM f = liftM catMaybes . mapM f

parse822Time :: String -> UTCTime
parse822Time = zonedTimeToUTC
              . fromJust
              . parseTime defaultTimeLocale rfc822DateFormat

sndMaybe :: (a, Maybe b) -> Maybe (a,b)
sndMaybe (a, Just b) = Just (a,b)
sndMaybe (a, Nothing) = Nothing


--combine two rule responses
andrr :: RuleResponse -> RuleResponse -> Exp RuleResponse
andrr a@(BoolResp _) b@(MsgResp _) = andrr b a
andrr (BoolResp a) (BoolResp b) = return $ BoolResp $ a && b
andrr (MsgResp m1@(Message s1)) (MsgResp m2@(Message s2)) = do
    let m = Message (s1 ++ " and " ++ s2)
    v <- newArrayVarOnce (s1 ++ ", " ++ s2) [1::Integer, 2] (f m)
    return (MsgResp m) where
        f m ((_, a):(_, b):[]) = sendMessage m $ a && b
andrr (MsgResp m1@(Message s1)) (BoolResp b2) = do
    let m = Message (s1 ++ " and " ++ (show b2))
    onMessageOnce m1 (f m)
    return (MsgResp m) where
        f m (MessageData b1) = sendMessage m $ b1 && b2

andrrs :: [RuleResponse] -> Exp RuleResponse
andrrs l = foldM andrr (BoolResp True) l

--combine two rules
(&&.) :: RuleFunc -> RuleFunc -> RuleFunc
(VoidRule r1) &&. (VoidRule r2) =  VoidRule $ r1 >> r2
rf1@(VoidRule _) &&. rf2@(RuleRule _) =  rf2 &&. rf1
(RuleRule r1) &&. (VoidRule r2) =  RuleRule $ \a -> do
    res <- r1 a
    r2
    return res
(RuleRule r1) &&. (RuleRule r2) =  RuleRule $ \a -> do
    res1 <- r1 a
    res2 <- r2 a
    res <- andrr res1 res2
    return res
_ &&. _ = error "rules impossible to combine"

-- | a default rule
defaultRule = Rule  {
    rNumber       = 1,
    rName         = "",
    rDescription  = "",
    rProposedBy   = 0,
    rRuleCode     = "",
    rRuleFunc     = VoidRule $ return (),
    rStatus       = Pending,
    rAssessedBy   = Nothing}