1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Control.Monad.SariulClocks ( SariulScoresMonad
, SariulClocksCGI
, SariulClocksIO
, runSariulClocksCGI
, runSariulClocksIO
, putSession
, getSession
, putScores
, getScores
, modifyScores) where
import Control.Monad (liftM)
import Control.Monad.Trans (MonadIO, lift)
import Control.Monad.State (StateT, MonadState, get, put, evalStateT)
import Types.Session
import Types.Scores
import Types.Classes
import Data.Classes
import Network.CGI.Monad (CGIT, MonadCGI, cgiAddHeader, cgiGet)
import Network.CGI (runCGI, handleErrors, CGIResult)
class ( Monad a
, MonadIO a) => SariulScoresMonad a where
putScores :: ScoresList -> a ()
getScores :: a ScoresList
modifyScores :: (ScoresList -> ScoresList) -> a ()
modifyScores f = do
scores <- getScores
let scores' = f scores
putScores scores
return ()
newtype SariulClocksCGI a =
SCC { getSCC :: StateT (Session, ScoresList) (CGIT IO) a }
deriving (Monad, MonadIO, MonadState (Session, ScoresList))
newtype SariulClocksIO a =
SCI { getSCI :: StateT ScoresList IO a }
deriving (Monad, MonadIO, MonadState ScoresList)
instance MonadCGI SariulClocksCGI where
cgiAddHeader n v = SCC . lift $ cgiAddHeader n v
cgiGet x = SCC . lift $ cgiGet x
instance SariulScoresMonad SariulClocksCGI where
getScores = liftM snd get
putScores s = do
(x, _) <- get
put (x, s)
instance SariulScoresMonad SariulClocksIO where
getScores = get
putScores = put
putSession :: Session -> SariulClocksCGI ()
putSession s = do
(_, y) <- get
put (s, y)
getSession :: SariulClocksCGI Session
getSession = liftM fst get
runSariulClocksCGI :: SariulClocksCGI CGIResult -> IO ()
runSariulClocksCGI k =
runCGI $ handleErrors $
evalStateT (getSCC k) (freshSession, zeroScores)
runSariulClocksIO :: SariulClocksIO () -> IO ()
runSariulClocksIO k = evalStateT (getSCI k) zeroScores
|
