module Utils.Schedule.Week
  ( weekSchedule
  ) where

import Import

import qualified Data.CaseInsensitive as CI

import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E

import Handler.Utils.DateTime (formatTimeRangeW, formatTimeW)

import Utils.Course (mayViewCourse, isCourseLecturer)

import Utils.Schedule.Types
import Utils.Schedule.Week.TimeSlot


-- TODO: implement dayOffset
weekSchedule :: UserId -> Maybe Integer -> Widget
weekSchedule uid _dayOffset = do
  now <- liftIO getCurrentTime
  tz  <- liftIO getCurrentTimeZone
  ata <- getSessionActiveAuthTags

  -- TODO: single runDB for all fetches below?
  
  activeTerms <- liftHandler . runDB $ E.select $ E.from $ \term -> do
    E.where_ $ term E.^. TermActive
    return $ term E.^. TermId

  -- TODO: fetch course events for this week only?
  courseEvents <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` courseEvent) -> do
    E.on $ course E.^. CourseId E.==. courseEvent E.^. CourseEventCourse
    E.where_ $ (E.exists $ E.from $ \courseParticipant -> E.where_ $ 
              courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
        E.&&. courseParticipant E.^. CourseParticipantUser   E.==. E.val uid
        E.&&. courseParticipant E.^. CourseParticipantState  E.==. E.val CourseParticipantActive
        E.&&. mayViewCourse (Just uid) ata now course Nothing  -- should not be necessary, but let's be on the safe side
      ) E.||. (E.exists $ E.from $ \lecturer -> E.where_ $
              lecturer          E.^. LecturerCourse          E.==. course E.^. CourseId
        E.&&. lecturer          E.^. LecturerUser            E.==. E.val uid
      )
    return (course, courseEvent)

  tutorials <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` tutorial) -> do
    E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
    E.where_ $ (E.exists $ E.from $ \tutorialParticipant -> E.where_ $
              tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
        E.&&. tutorialParticipant E.^. TutorialParticipantUser     E.==. E.val uid
        E.&&. mayViewCourse (Just uid) ata now course Nothing  -- should not be necessary, but let's be on the safe side
      ) E.||. (E.exists $ E.from $ \tutor -> E.where_ $
              tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
        E.&&. tutor E.^. TutorUser     E.==. E.val uid
      )
    return (course, tutorial)
  
  -- TODO: this makes the exam table redundant once the weekOffset is implemented
  -- TODO: for lecturers, do not display one entry for each exam occurrences, but instead collect all occurrences happening at the same time in a list
  examOccurrences <- liftHandler . runDB $ E.select $ E.from $ \((course `E.InnerJoin` exam) `E.LeftOuterJoin` examOccurrence) -> do
    E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
    E.on $ E.just (exam E.^. ExamId) E.==. examOccurrence E.?. ExamOccurrenceExam
    E.where_ $ isCourseLecturer (Just uid) ata (course E.^. CourseId)
      E.||. (E.exists $ E.from $ \examRegistration -> E.where_ $
              examRegistration E.?. ExamRegistrationUser E.==. E.just (E.val uid)
        E.&&. E.maybe E.false (\visibleFrom -> visibleFrom E.<=. E.val now) (exam E.^. ExamVisibleFrom)
        E.&&. mayViewCourse (Just uid) ata now course Nothing)  -- do NOT remove, this is actually necessary here!
                                                                -- (There can be exam participants that are 
                                                                --  not enrolled, me thinks)
    return (course, exam, examOccurrence)
  
  let
    courseEventToScheduleEntries :: (Entity Course, Entity CourseEvent) -> [ScheduleEntry]
    courseEventToScheduleEntries (seCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType,courseEventRoom,courseEventTime=Occurrences{..}}) =
      let seType        = SETCourseEvent { setceType = courseEventType }
          seRoom        = Just courseEventRoom
          scheduleds
            -- omit regular occurrences if the course's term is not currently active
            | not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty
            | otherwise = Set.toList occurrencesScheduled <&> \scheduled ->
                            let seOccurrence = Right (Right scheduled) in ScheduleEntry{..}
          exceptions    = Set.toList occurrencesExceptions <&> \exception ->
                            let seOccurrence = Right (Left exception) in ScheduleEntry{..}
      in  scheduleds <> exceptions

    tutorialToScheduleEntries :: (Entity Course, Entity Tutorial) -> [ScheduleEntry]
    tutorialToScheduleEntries (seCourse@(Entity _ Course{..}), Entity _ Tutorial{tutorialType,tutorialName,tutorialRoom,tutorialTime=Occurrences{..}}) =
      let seType        = SETTutorial { settType = tutorialType, settName = tutorialName }
          seRoom        = tutorialRoom
          scheduleds
            -- omit regular occurrences if the course's term is not currently active
            | not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty
            | otherwise = Set.toList occurrencesScheduled  <&> \scheduled ->
                            let seOccurrence = Right (Right scheduled) in ScheduleEntry{..}
          exceptions    = Set.toList occurrencesExceptions <&> \exception ->
                            let seOccurrence = Right (Left exception) in ScheduleEntry{..}
      in  scheduleds <> exceptions

    examOccurrenceToScheduleEntry :: (Entity Course, Entity Exam, Maybe (Entity ExamOccurrence)) -> Maybe ScheduleEntry
    examOccurrenceToScheduleEntry (seCourse@(Entity _ Course{}), Entity _ Exam{..}, Just (Entity _ ExamOccurrence{..})) =
      let seType       = SETExamOccurrence
                         { seteoExamName = examName
                         }
          seRoom       = Just examOccurrenceRoom
          seOccurrence = Left $ ScheduleEntryExamOccurrence
                         { seeoStart = examOccurrenceStart
                         , seeoEnd   = examOccurrenceEnd
                         }
      in  Just ScheduleEntry{..}
    examOccurrenceToScheduleEntry _ = Nothing  -- TODO: exclude (_,_,Nothing) case via join
    
    seOccurrenceIsInSlot :: Day -> TimeSlot -> ScheduleEntryOccurrence -> Bool
    seOccurrenceIsInSlot day slot = \case
      Right occurrence -> occStart `isInTimeSlot` (day, slot) where
        occStart = case occurrence of
                     Right ScheduleWeekly{..} -> (scheduleDayOfWeek `dayOfWeekToDayWith` now, scheduleStart)
                     Left ExceptOccur{..} -> (exceptDay, exceptStart)
                     Left ExceptNoOccur{exceptTime=LocalTime{..}} -> (localDay, localTimeOfDay)
      Left ScheduleEntryExamOccurrence{..} -> let slotUTCTime     = timeSlotToUTCTime tz day slot
                                                  nextSlotUTCTime = timeSlotToUTCTime tz day (slot+slotStep)
                                              in slotUTCTime <= seeoStart
                                                 && seeoStart < nextSlotUTCTime
    
    events' :: Map Day (Map Int [ScheduleEntry])
    events' = Map.fromList $ week <&> \day ->
      ( day
      , Map.fromList $ slotsToDisplay <&> \slot ->
        ( slot
        , filter (seOccurrenceIsInSlot day slot . seOccurrence) $ join $
               (courseEventToScheduleEntries  <$> courseEvents)
            <> (tutorialToScheduleEntries     <$> tutorials)
            <> (pure . catMaybes) (examOccurrenceToScheduleEntry <$> examOccurrences)
        )
      )

    events :: Map Day (Map Int [ScheduleEntry])
    events = events' <&> \slotsPerDay -> slotsPerDay <&> \occurrencesInSlot ->
      let
        isRegularWithoutException :: ScheduleEntry -> Bool
        isRegularWithoutException = \case
          -- remove regular occurrences if there is a NoOccur exception for the occurrence of this week
          ScheduleEntry{seOccurrence=Right (Right ScheduleWeekly{..})} ->
            -- TODO: is equality on scheduleStart sane?
            not $ Right (Left $ ExceptNoOccur $ LocalTime (scheduleDayOfWeek `dayOfWeekToDayWith` now) scheduleStart)
                  `elem` (seOccurrence <$> occurrencesInSlot)
          -- remove NoOccur exceptions if there is no regular occurrence to override
          ScheduleEntry{seOccurrence=Right (Left ExceptNoOccur{exceptTime=LocalTime{..}})} ->
            any (\case
                   -- TODO: is equality on scheduleStart sane?
                   Right (Right ScheduleWeekly{..}) -> scheduleDayOfWeek `dayOfWeekToDayWith` now == localDay
                                               && scheduleStart == localTimeOfDay
                   _ -> False
              ) (seOccurrence <$> occurrencesInSlot)
          _ -> True  -- TODO: maybe filter out ExceptNoOccurs? (Should NoOccurs be displayed or not?)
      in filter isRegularWithoutException occurrencesInSlot

    -- TODO: Internationalize default week start (and/or make configurable)
    -- TODO: auto-hide saturday and sunday (if there are no events scheduled)?
    week :: [Day]
    week = go $ utctDay now
      where go day
              | Monday <- dayOfWeek day = [day .. toEnum (fromEnum day + 6)]
              | otherwise = go $ pred day

  $(widgetFile "widgets/schedule/week")


-- Local helper functions

-- | To which route should each schedule entry link to?
scheduleEntryToHref :: ScheduleEntry -> Route UniWorX
scheduleEntryToHref ScheduleEntry{seCourse=Entity _ Course{..},seType} = case seType of
  SETCourseEvent{} -> CourseR courseTerm courseSchool courseShorthand CShowR  -- TODO: link to events table? (TODO currently has no id)
  SETTutorial{} -> CourseR courseTerm courseSchool courseShorthand CShowR  -- TODO: link to table with id "tutorials"?
  SETExamOccurrence{..} -> CExamR courseTerm courseSchool courseShorthand seteoExamName EShowR

-- | Calls formatTimeRangeW with the correct arguments and prepends an occurrence descriptor based on the occurrence type
formatOccurrenceW :: ScheduleEntryOccurrence -> Widget
formatOccurrenceW = \case
  Right (Right ScheduleWeekly{..}) -> [whamlet| _{MsgScheduleTime}: |] <> formatTimeRangeW SelFormatTime scheduleStart (Just scheduleEnd)
  Right (Left ExceptOccur{..}) -> [whamlet| _{MsgScheduleOccur}: |] <> formatTimeRangeW SelFormatTime (LocalTime exceptDay exceptStart) (Just $ LocalTime exceptDay exceptEnd)
  Right (Left ExceptNoOccur{}) -> [whamlet| _{MsgScheduleNoOccur} |] -- <> formatTimeW SelFormatDateTime exceptTime
  Left ScheduleEntryExamOccurrence{..} -> [whamlet| _{MsgScheduleOccur}: |] <> formatTimeRangeW SelFormatTime seeoStart seeoEnd

-- | Uniquely identify each day as table head
-- | This avoids constantly hiding e.g. some DayOfWeek (which would interfere with day offsets)
dayTableHeadIdent :: Day -> Text
dayTableHeadIdent = tshow . toModifiedJulianDay

-- | Convert from DayOfWeek to Day of this week using the current time (as UTCTime)
dayOfWeekToDayWith :: DayOfWeek -> UTCTime -> Day
dayOfWeekToDayWith weekDay = go . utctDay where
  go day | weekDay' == weekDay = day
         | weekDay' >  weekDay = go $ pred day
         | otherwise           = go $ succ day
         where weekDay' = dayOfWeek day