minesweeper-0.9: Driver/Log.hs

{-# LANGUAGE PatternGuards #-}

module Driver.Log
    ( Result (..)
    , Transition
    , DriverState
    , applyTransition
    , initDriverState
    , takeState
    ) where

import When
import Log
import Driver (DriverState, initDriverState)
import qualified Driver as D

import Data.Time.Clock
import Data.List

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

type Transition st a b
    = st -> Maybe (Result a b, st)

data Result a b
    = Result 
        { result    :: b
        , triggered :: [Timed a]
        , cancelled :: [a]
        }


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

takeState :: DriverState st a -> IO st
takeState = fmap snd . D.takeState

applyTransition
    :: (Eq a, Ord a, Show a, Show b) 
    => LogState
    -> DriverState st a
    -> (UTCTime -> b -> IO ())
    -> (a -> Transition st a b) 
    -> a
    -> IO ()

applyTransition logState dst handleResponse transition a
    = D.applyTransition dst tr (tr a)

 where
    tr e st
        | Just (res, new_st) <- transition e st
        = (cancelled res, triggered res, f2 e res, new_st)
        | otherwise
        = ([], [], f1 e, st)

    f1 e _time 
        = writeLog logState [{-"Event " ++ -} show e ++ {- " at " ++ show time ++ -} " was ignored."]

    f2 e res time = do
        writeLog logState $ ({-"Event " ++ -} show e {- ++ " at " ++ show time ++ " results:" -}) : map ("  " ++) (showResult res)
        handleResponse time $ result res


------------------------ logging --------------------

showResult :: (Show a, Show b) => Result a b -> [String]
showResult r = filter (not . null)
    [ sh "  cancelled" $ map show $ cancelled r
    , sh "  triggered" $ map f $ triggered r
    , sh "  result   " $ [show $ result r]
    ]

 where
    sh :: String -> [String] -> String
    sh _ [] = ""
    sh s l  = s ++ ": " ++ intercalate ", " l

    f (w, e) = show w ++ ": " ++ show e