module Villefort.Daily where
import Villefort.Time
import Villefort.Definitions
import Villefort.Database
import Villefort.Stats
import Villefort.Todo
import Villefort.Summary
import Villefort.Config
import Control.Monad.Reader
import Control.Monad.IO.Class
import Data.Time
import Data.Time.Calendar.WeekDate
import Data.List
import Data.Function
weeklyStats :: (MonadReader VConfig m, MonadIO m) => m String
weeklyStats = do
dates<- liftIO getDatesOfWeek
header <- getHeader
(_,numWeek,_) <- liftIO $ toWeekDate <$> getDate
let addWeek = ( ("<h1> Week " ++ show numWeek ++ "</h1> ") ++ )
z <- (header ++ ) <$> addWeek <$> mconcat <$> mapM getSummaryDay dates
d <- genTabs
return $ z ++ d
getSummaryDay :: (MonadReader VConfig m, MonadIO m) => Day -> m String
getSummaryDay day = do
dat <- getDoneDay $ show day
return ( (lookup !! week) ++ (makeTable ["Subject","Time"] $ dat ++ [["Total", show$ total dat]]))
where (_,_,week) = toWeekDate day
lookup =["","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday","Sunday"]
getPrevWeek :: (MonadReader VConfig m, MonadIO m) => m [[String]]
getPrevWeek = do
z <- liftIO $ getDatesOfPrevWeek
t z
where t = (\x -> getSubWeek (show $ x !! 0) (show $ x !! 1))
getThisWeek :: (MonadReader VConfig m, MonadIO m) => m [[String]]
getThisWeek = do
z <- liftIO $ getDatesOfThisWeek
t z
where t = (\x -> getSubWeek (show $ x !! 0) (show $ x !! 1))
genTabs :: (MonadReader VConfig m, MonadIO m) => m String
genTabs = do
z <- getThisWeek
t <- getPrevWeek
return $ makeTable ["Subject","Last week ","This week "] $ n $ spec1 t z
spec1 x y = merge1 (fst main) (snd main)
where set = nub $ map (\x -> x !! 0) $ x ++ y
elem1 x y= any (\z -> z !! 0 == x) y
diff1 = map (\q -> elem1 q x) set
diff2 = map (\q -> elem1 q y) set
set1 = zipWithPadding " " [" ","0"] set x
set2 = zipWithPadding " " [" ","0"] set y
main = (map (\q -> z (fst q) (snd q) ) $ zip diff1 set1,
map (\q -> z (fst q) (snd q) ) $ zip diff2 set2)
z :: Bool -> (String,[String]) -> [String]
z x y = if x then snd y else [fst y,"0"]
zipWithPadding :: a -> b -> [a] -> [b] -> [(a,b)]
zipWithPadding a b (x:xs) (y:ys) = (x,y) : zipWithPadding a b xs ys
zipWithPadding a _ [] ys = zip (repeat a) ys
zipWithPadding _ b xs [] = zip xs (repeat b)
merge1 :: [a] -> [a] -> [a]
merge1 xs [] = xs
merge1 [] ys = ys
merge1 (x:xs) (y:ys) = x : y : merge xs ys
n (x:y:xs) = [(x ++ [(y !! 1)])] ++ n xs
n [] = []