diff options
author | Sean Whitton <spwhitton@spwhitton.name> | 2015-03-20 13:23:55 +0000 |
---|---|---|
committer | Sean Whitton <spwhitton@spwhitton.name> | 2015-03-20 13:23:55 +0000 |
commit | 0794f62270cf071d3571460d2c1c70eec220c9a4 (patch) | |
tree | 96721f448f66334c57fcded45262146d1bbf8381 /src | |
parent | 9f634c54de999a7a063833aa8f2f21f50a955016 (diff) | |
download | sariulclocks-0794f62270cf071d3571460d2c1c70eec220c9a4.tar.gz |
rewrite monad inc. a typeclass
Diffstat (limited to 'src')
-rw-r--r-- | src/Control/Monad/SariulClocks.hs | 58 |
1 files changed, 40 insertions, 18 deletions
diff --git a/src/Control/Monad/SariulClocks.hs b/src/Control/Monad/SariulClocks.hs index d143375..4d47161 100644 --- a/src/Control/Monad/SariulClocks.hs +++ b/src/Control/Monad/SariulClocks.hs @@ -1,7 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -module Control.Monad.SariulClocks ( SariulClocks +module Control.Monad.SariulClocks ( SariulScoresMonad + , SariulClocksCGI + , SariulClocksIO , putSession , getSession , putScores @@ -9,32 +10,53 @@ module Control.Monad.SariulClocks ( SariulClocks import Control.Monad (liftM) import Control.Monad.Trans (MonadIO, lift) -import Control.Monad.State (StateT, MonadState, get, put) +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) -newtype SariulClocks a = - SC { runSariulClocks :: StateT (Session, ScoresList) (CGIT IO) a } +class ( Monad a + , MonadIO a) => SariulScoresMonad a where + putScores :: ScoresList -> a () + getScores :: a ScoresList + +newtype SariulClocksCGI a = + SCC { getSCC :: StateT (Session, ScoresList) (CGIT IO) a } deriving (Monad, MonadIO, MonadState (Session, ScoresList)) -instance MonadCGI SariulClocks where - cgiAddHeader n v = SC . lift $ cgiAddHeader n v - cgiGet x = SC . lift $ cgiGet x +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 -> SariulClocks () +putSession :: Session -> SariulClocksCGI () putSession s = do - (_, y) <- get - put (s, y) + (_, y) <- get + put (s, y) -getSession :: SariulClocks Session +getSession :: SariulClocksCGI Session getSession = liftM fst get -getScores :: SariulClocks ScoresList -getScores = liftM snd get +runSariulClocksCGI :: SariulClocksCGI CGIResult -> IO () +runSariulClocksCGI k = + runCGI $ handleErrors $ + evalStateT (getSCC k) (freshSession, zeroScores) -putScores :: ScoresList -> SariulClocks () -putScores s = do - (x, _) <- get - put (x, s) +runSariulClocksIO :: SariulClocksIO () -> IO () +runSariulClocksIO k = evalStateT (getSCI k) zeroScores |