<commit_before>{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
{-# LANGUAGE GADTs, TypeFamilies #-}
{-# LANGUAGE QuasiQuotes, CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Handler.Issue where

import Import
import BISocie.Helpers.Util
import Control.Monad (when, unless, forM, liftM2)
import Data.List (intercalate, intersperse, nub, groupBy)
import Data.Time
import Data.Time.Calendar.WeekDate
import Data.Maybe (fromMaybe, fromJust, isJust, isNothing)
import qualified Data.Text.Lazy as L
import qualified Data.Text.Lazy.Encoding as LE
import qualified Data.Text as T
import Handler.S3
import Network.Mail.Mime
import Text.Blaze.Internal (preEscapedText)
import Yesod.Auth (requireAuthId)

getCurrentScheduleR :: Handler RepHtml
getCurrentScheduleR = do
  today <- liftIO $ fmap utctDay getCurrentTime
  let (y, m, _) = toGregorian today
  redirect $ ScheduleR y m
  
data WeekDay = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday
             deriving (Show, Eq, Ord, Enum)

getScheduleR :: Year -> Month -> Handler RepHtml
getScheduleR y m = do
  u <- requireAuth
  today <- liftIO $ fmap utctDay getCurrentTime
  let days = map (map (\(y,w,d) -> let day = fromWeekDate y w d in (day, classOf day d today)))
             $ groupBy (\d1 d2 -> snd3 d1 == snd3 d2)
             $ map toWeekDate [fromWeekDate fy fm 1 .. fromWeekDate ly lm 7]
  defaultLayout $ do
    setTitle $ preEscapedText $ showText y +++ "年" +++ showText m +++ "月のスケジュール"
    $(widgetFile "schedule")
  where
    fday = fromGregorian y m 1
    lday = fromGregorian y m $ gregorianMonthLength y m
    (fy, fm, _) = toWeekDate fday
    (ly, lm, _) = toWeekDate lday
    classOf :: Day -> Int -> Day -> String
    classOf day d today = intercalate " " 
                          $ ["schedule-day-cell", toWeekName d] 
                           ++ (if today == day then ["today"] else [])
                           ++ (if currentMonth day then ["currentMonth"] else ["otherMonth"])
    taskUri :: Day -> Route BISocie
    taskUri d = let (y', m', d') = toGregorian d in TaskR y' m' d'
    showDay :: Day -> String
    showDay = show . thd3 . toGregorian
    currentMonth :: Day -> Bool
    currentMonth d = let (y', m', _) = toGregorian d in y == y' && m == m'
    monthmove n cm = let (y', m', _) = toGregorian $ addGregorianMonthsClip n cm
                     in ScheduleR y' m'
    prevMonth = monthmove (-1)
    nextMonth = monthmove 1
    prevYear = monthmove (-12)
    nextYear = monthmove 12
    toWeekName :: Int -> String<commit_msg>Refactor: getScheduleR<commit_after>{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
{-# LANGUAGE GADTs, TypeFamilies #-}
{-# LANGUAGE QuasiQuotes, CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Handler.Issue where

import Import
import BISocie.Helpers.Util
import Control.Monad (when, unless, forM, liftM2)
import Data.Function (on)
import Data.List (intercalate, intersperse, nub, groupBy)
import Data.Time
import Data.Time.Calendar.WeekDate
import Data.Maybe (fromMaybe, fromJust, isJust, isNothing)
import qualified Data.Text.Lazy as L
import qualified Data.Text.Lazy.Encoding as LE
import qualified Data.Text as T
import Handler.S3
import Network.Mail.Mime
import Text.Blaze.Internal (preEscapedText)
import Yesod.Auth (requireAuthId)

getCurrentScheduleR :: Handler RepHtml
getCurrentScheduleR = do
  today <- liftIO $ fmap utctDay getCurrentTime
  let (y, m, _) = toGregorian today
  redirect $ ScheduleR y m
  
data WeekDay = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday
             deriving (Show, Eq, Ord, Enum)

getScheduleR :: Year -> Month -> Handler RepHtml
getScheduleR y m = do
  u <- requireAuth
  today <- liftIO $ fmap utctDay getCurrentTime
  let days = map (map (\(y,w,d) -> let day = fromWeekDate y w d in (day, classOf day d today)))
             $ groupBy ((==) `on` snd3)
             $ map toWeekDate [fromWeekDate fy fm 1 .. fromWeekDate ly lm 7]
  defaultLayout $ do
    setTitle $ preEscapedText $ showText y +++ "年" +++ showText m +++ "月のスケジュール"
    $(widgetFile "schedule")
  where
    fday = fromGregorian y m 1
    lday = fromGregorian y m $ gregorianMonthLength y m
    (fy, fm, _) = toWeekDate fday
    (ly, lm, _) = toWeekDate lday
    classOf :: Day -> Int -> Day -> String
    classOf day d today = intercalate " " 
                          $ ["schedule-day-cell", toWeekName d] 
                           ++ (if today == day then ["today"] else [])
                           ++ (if currentMonth day then ["currentMonth"] else ["otherMonth"])
    taskUri :: Day -> Route BISocie
    taskUri d = let (y', m', d') = toGregorian d in TaskR y' m' d'
    showDay :: Day -> String
    showDay = show . thd3 . toGregorian
    currentMonth :: Day -> Bool
    currentMonth d = let (y', m', _) = toGregorian d in y == y' && m == m'
    monthmove n cm = let (y', m', _) = toGregorian $ addGregorianMonthsClip n cm
                     in ScheduleR y' m'
    prevMonth = monthmove (-1)
    nextMonth = monthmove 1
    prevYear = monthmove (-12)
    nextYear = monthmove 12
    toWeekName :: Int -> String
{'fraction_non_alphanumeric': 0.11627049935507647, 'fraction_numerical': 0.005712179841533075, 'mean_word_length': 2.9191335740072204, 'pattern_counts': {'":': 0, '<': 9, '<?xml version=': 0, '>': 24, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 4, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '59594', 'n_tokens_mistral': 1865, 'n_tokens_neox': 1772, 'n_words': 567}