rewrite monad inc. a typeclass

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