From 61e7a904975518c6ab61589010dbf7b25fc21e48 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Sat, 21 Mar 2015 18:44:24 +0900 Subject: fix monad with latest GHC. pretty print scores. --- src/Control/Monad/SariulClocks.hs | 23 ++++++++-------- src/Utils/ScoresFile.hs | 51 +++++++++++++++++------------------ src/sariulccron.hs | 56 ++++++++++++++++++++++++++++----------- 3 files changed, 77 insertions(+), 53 deletions(-) diff --git a/src/Control/Monad/SariulClocks.hs b/src/Control/Monad/SariulClocks.hs index fc5a7e5..e25add2 100644 --- a/src/Control/Monad/SariulClocks.hs +++ b/src/Control/Monad/SariulClocks.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Control.Monad.SariulClocks ( SariulScoresMonad @@ -11,15 +12,15 @@ module Control.Monad.SariulClocks ( SariulScoresMonad , 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) +import Control.Monad (liftM) +import Control.Monad.State (MonadState, StateT, evalStateT, get, put) +import Control.Monad.Trans (MonadIO, lift) +import Data.Classes +import Network.CGI (CGIResult, handleErrors, runCGI) +import Network.CGI.Monad (CGIT, MonadCGI, cgiAddHeader, cgiGet) +import Types.Classes +import Types.Scores +import Types.Session class ( Monad a , MonadIO a) => SariulScoresMonad a where @@ -34,11 +35,11 @@ class ( Monad a newtype SariulClocksCGI a = SCC { getSCC :: StateT (Session, ScoresList) (CGIT IO) a } - deriving (Monad, MonadIO, MonadState (Session, ScoresList)) + deriving (Functor, Applicative, Monad, MonadIO, MonadState (Session, ScoresList)) newtype SariulClocksIO a = SCI { getSCI :: StateT ScoresList IO a } - deriving (Monad, MonadIO, MonadState ScoresList) + deriving (Functor, Applicative, Monad, MonadIO, MonadState ScoresList) instance MonadCGI SariulClocksCGI where cgiAddHeader n v = SCC . lift $ cgiAddHeader n v diff --git a/src/Utils/ScoresFile.hs b/src/Utils/ScoresFile.hs index f981a4a..eac386c 100644 --- a/src/Utils/ScoresFile.hs +++ b/src/Utils/ScoresFile.hs @@ -14,7 +14,7 @@ import Control.Monad (liftM) import Data.List.Split (splitOn) import Data.Maybe (fromJust) import System.FilePath (()) --- import Control.Monad.SariulClocks +import Control.Monad.SariulClocks import Control.Monad.Trans (liftIO) scoresToCSV :: ScoresList -> String @@ -35,30 +35,27 @@ scoresFromCSV csv = foldr step [] (lines csv) classString:scoreString:timeString:[] = splitOn "," line theClass = fromJust $ lookupSariulClass ((read . (:[]) . head) classString) ((read . (:[]) . last) classString) --- -- try to read from scores-XX.csv where XX is largest timestamp --- readScoresFile :: SariulScoresMonad a => a (Maybe ScoresList) --- readScoresFile = do --- curDir <- liftIO getCurrentDirectory --- let dataDir = curDir "data" --- filenames <- liftM (reverse . sort . filter isCSV) $ liftIO $ getDirectoryContents dataDir --- if null filenames --- then return Nothing --- else do --- -- let scores = liftM scoresFromCSV $ liftIO $ readFile (dataDir head filenames) --- scores <- liftIO $ scoresFromCSV <$> readFile (dataDir head filenames) --- putScores scores --- return $ Just scores --- where isCSV path = takeExtension path == ".csv" +-- try to read from scores-XX.csv where XX is largest timestamp +readScoresFile :: SariulScoresMonad a => a (Maybe ScoresList) +readScoresFile = do + curDir <- liftIO getCurrentDirectory + let dataDir = curDir "data" + filenames <- liftM (reverse . sort . filter isCSV) $ liftIO $ getDirectoryContents dataDir + if null filenames + then return Nothing + else do + -- let scores = liftM scoresFromCSV $ liftIO $ readFile (dataDir head filenames) + scores <- liftIO $ scoresFromCSV <$> readFile (dataDir head filenames) + putScores scores + return $ Just scores + where isCSV path = takeExtension path == ".csv" --- -- writes to score-XX.csv where XX is unix timestamp: a simple-minded logging --- writeScoresFile :: SariulScoresMonad a => a () --- writeScoresFile = do --- scores <- getScores --- curDir <- liftIO getCurrentDirectory --- let dataDir = curDir "data" --- timestamp <- liftM round $ liftIO getPOSIXTime --- let filename = dataDir ("scores-" ++ show timestamp ++ ".csv") --- liftIO $ writeFile filename (scoresToCSV scores) - -readScoresFile = undefined -writeScoresFile = undefined +-- writes to score-XX.csv where XX is unix timestamp: a simple-minded logging +writeScoresFile :: SariulScoresMonad a => a () +writeScoresFile = do + scores <- getScores + curDir <- liftIO getCurrentDirectory + let dataDir = curDir "data" + timestamp <- liftM round $ liftIO getPOSIXTime + let filename = dataDir ("scores-" ++ show timestamp ++ ".csv") + liftIO $ writeFile filename (scoresToCSV scores) diff --git a/src/sariulccron.hs b/src/sariulccron.hs index 87b5e30..d36258e 100644 --- a/src/sariulccron.hs +++ b/src/sariulccron.hs @@ -1,23 +1,49 @@ --- import Control.Monad.SariulClocks -import Utils.ScoresFile -import Types.Scores -import Types.Classes -import Control.Monad (liftM, when) -import Text.PrettyPrint.Boxes +{-# LANGUAGE OverloadedStrings #-} +import Control.Monad (liftM, when) +import Control.Monad.SariulClocks +import Control.Monad.Trans (liftIO) +import Data.Classes +import Data.Maybe (fromJust) +import Text.PrettyPrint.Boxes +import Types.Classes +import Types.Scores +import Utils.ScoresFile -scoresBox :: ScoresList -> Box -scoresBox = undefined +--- meaty functions weeklyCron :: ScoresList -> ScoresList weeklyCron scores = undefined --- main :: IO () --- main = runSariulClocksIO $ do --- scores <- readScoresFile --- when (isJust scores) $ do --- modifyScores weeklyCron --- shouldModify <- liftM (((/=) scores) . Just) getScores --- when shouldModify writeScoresFile +main :: IO () +main = runSariulClocksIO $ do + scores <- readScoresFile + when (isJust scores) $ do + modifyScores weeklyCron + shouldModify <- liftM (((/=) scores) . Just) getScores + liftIO $ putStrLn "Scores before:\n" + liftIO $ putStrLn . ppScores $ fromJust scores + liftIO $ putStrLn "Scores after:\n" + scores' <- getScores + liftIO $ putStrLn . ppScores $ scores' + when shouldModify writeScoresFile + +--- utility functions + +ppScores :: ScoresList -> String +ppScores x = render $ + hsep 3 center1 [ alignHoriz center2 7 "Class" + , alignHoriz center1 7 "Points" + , alignHoriz center1 12 "Time wasted"] + // "--------------------------------" + // foldr step nullBox x + where + step b bs = classBox b // bs + +classBox :: (Class, Score) -> Box +classBox (c, (Score x y)) = hsep 3 left + [ alignHoriz center1 7 $ (text . show) c + , alignHoriz center1 7 $ (text . show) x + , alignHoriz center1 12 $ (text . show) y] isJust :: Maybe a -> Bool isJust (Just _) = True -- cgit v1.2.3