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


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

  let dayNowOffset = fromMaybe 0 dayOffset `addDays` utctDay now

  -- 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 partly redundant => maybe remove?
  examOccurrences <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examOccurrence) -> do
    E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
    E.on $ 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.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 (sceCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType=sceType,courseEventRoom=sceRoom,courseEventTime=Occurrences{..}}) =
      let scheduleds
            -- omit regular occurrences if the course term is not currently active
            | not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty
            | otherwise = Set.toList occurrencesScheduled  <&> \scheduled ->
                            let sceOccurrence = Right scheduled in ScheduleCourseEvent{..}
          exceptions    = Set.toList occurrencesExceptions <&> \exception ->
                            let sceOccurrence = Left  exception in ScheduleCourseEvent{..}
      in  scheduleds <> exceptions

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

    -- TODO: introduce type synonym for (Entity Course, Entity Exam, Entity ExamOccurrence)?
    joinParallelExamOccurrences :: [(Entity Course, Entity Exam, Entity ExamOccurrence)] -> [(Entity Course, Entity Exam, NonEmpty (Entity ExamOccurrence))]
    joinParallelExamOccurrences = go [] where
      go acc [] = acc
      go acc (examOcc@(course, exam, occ):examOccs) =
        let ((((view _3) <$>) -> parallel), other) = partition (examOcc `isParallelTo`) examOccs
        in  go ((course, exam, occ:|parallel):acc) other
      (Entity cid _, Entity eid _, Entity _ occ) `isParallelTo` (Entity cid' _, Entity eid' _, Entity _ occ') =
           cid == cid' && eid == eid'
        && examOccurrenceStart occ == examOccurrenceStart occ' && examOccurrenceEnd occ == examOccurrenceEnd occ'
    
    examOccurrenceToScheduleEntry :: (Entity Course, Entity Exam, NonEmpty (Entity ExamOccurrence)) -> ScheduleEntry
    examOccurrenceToScheduleEntry (seoCourse@(Entity _ Course{}), Entity _ Exam{examName=seoExamName}, examOccs@((Entity _ occ):|_)) =
      let seoRooms = (examOccurrenceRoom . entityVal) <$> examOccs
          seoStart =  examOccurrenceStart occ  -- multiple exam occurrences are joined on equality of start and end,
          seoEnd   =  examOccurrenceEnd   occ  -- so taking the timestamps of the first occurrence suffices
      in  ScheduleExamOccurrence{..}
    
    seIsInSlot :: Day -> TimeSlot -> ScheduleEntry -> Bool
    seIsInSlot day slot =
      let occurrenceIsInSlot occurrence = occDay == day && occTime `isInTimeSlot` slot where
            (occDay, occTime) = case occurrence of
                                  Right ScheduleWeekly{..} -> (scheduleDayOfWeek `dayOfWeekToDayWith` dayNowOffset, scheduleStart)
                                  Left ExceptOccur{..} -> (exceptDay, exceptStart)
                                  Left ExceptNoOccur{exceptTime=LocalTime{..}} -> (localDay, localTimeOfDay)
      in \case
        ScheduleCourseEvent{sceOccurrence} -> occurrenceIsInSlot sceOccurrence
        ScheduleTutorial{stOccurrence}     -> occurrenceIsInSlot stOccurrence
        ScheduleExamOccurrence{seoStart}   -> let slotTime     = timeSlotToUTCTime tz day  slot
                                                  nextSlotTime = timeSlotToUTCTime tz day (slot+slotStep)
                                              in slotTime <= seoStart
                                                 && seoStart < nextSlotTime
    
    events' :: Map Day (Map TimeSlot [ScheduleEntry])
    events' = Map.fromList $ week <&> \day ->
      ( day
      , Map.fromList $ slotsToDisplay <&> \slot ->
        ( slot
        , filter (seIsInSlot day slot) $ join $
                    (courseEventToScheduleEntries  <$> courseEvents)
            <>      (tutorialToScheduleEntries     <$> tutorials)
            <> pure (examOccurrenceToScheduleEntry <$> (joinParallelExamOccurrences examOccurrences))
        )
      )

    getRegulars :: [ScheduleEntry] -> [OccurrenceSchedule]
    getRegulars = catMaybes . (goRegular <$>) where
      goRegular ScheduleCourseEvent{sceOccurrence=Right schedule} = Just schedule
      goRegular ScheduleTutorial{stOccurrence=Right schedule}     = Just schedule
      goRegular _ = Nothing

    getNoOccurs :: [ScheduleEntry] -> [OccurrenceException]
    getNoOccurs = catMaybes . (goNoOccur <$>) where
      goNoOccur ScheduleCourseEvent{sceOccurrence=Left noOccur} = Just noOccur
      goNoOccur ScheduleTutorial{stOccurrence=Left noOccur}     = Just noOccur
      goNoOccur _ = Nothing

    events :: Map Day (Map TimeSlot [ScheduleEntry])
    events = events' <&> \slotsPerDay -> slotsPerDay <&> \occurrencesInSlot ->
      let
        isRegularWithoutException :: ScheduleEntry -> Bool
        isRegularWithoutException =
          let -- remove regular occurrences if there is a NoOccur exception for the occurrence of this week
              goPrune (Right ScheduleWeekly{..}) = not $ ExceptNoOccur (LocalTime (scheduleDayOfWeek `dayOfWeekToDayWith` dayNowOffset) scheduleStart) `elem` (getNoOccurs occurrencesInSlot)
              -- remove NoOccur exceptions if there is no regular occurrence to override
              goPrune (Left ExceptNoOccur{exceptTime=LocalTime{..}}) =
                any (\ScheduleWeekly{..} -> scheduleDayOfWeek `dayOfWeekToDayWith` dayNowOffset == localDay
                                           && scheduleStart == localTimeOfDay
                  ) (getRegulars occurrencesInSlot)
              goPrune _ = True  -- TODO: maybe filter NoOccur exceptions in general? (Should NoOccur exceptions be displayed?)
          in \case
            ScheduleCourseEvent{sceOccurrence} -> goPrune sceOccurrence
            ScheduleTutorial{stOccurrence} -> goPrune stOccurrence
            _ -> True
      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 $ fromMaybe 0 dayOffset `addDays` utctDay now
      where go day
              | dayOfWeek day == firstDay = [day .. toEnum (fromEnum day + 6)]
              | otherwise = go $ pred day
            firstDay = toEnum $ fromEnum Monday + fromInteger (fromMaybe 0 dayOffset)

  $(widgetFile "widgets/schedule/week")


-- Local helper functions

-- | To which route should each schedule entry link to?
scheduleEntryToHref :: ScheduleEntry -> Route UniWorX
scheduleEntryToHref = \case
  ScheduleCourseEvent{sceCourse=(Entity _ Course{..})} -> CourseR courseTerm courseSchool courseShorthand CShowR  -- TODO: link to events table? (currently has no id)
  ScheduleTutorial{stCourse=(Entity _ Course{..})} -> CourseR courseTerm courseSchool courseShorthand CShowR  -- TODO: link to table with id "tutorials"?
  ScheduleExamOccurrence{seoCourse=(Entity _ Course{..}),seoExamName} -> CExamR courseTerm courseSchool courseShorthand seoExamName EShowR

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

-- | 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 day
dayOfWeekToDayWith :: DayOfWeek -> Day -> Day
dayOfWeekToDayWith weekDay = go where
  go day | weekDay' == weekDay = day
         | weekDay' >  weekDay = go $ pred day
         | otherwise           = go $ succ day
         where weekDay' = dayOfWeek day