module Utils.Schedule.Week
  ( weekOffsets, 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 Handler.Utils.DateTime (formatTimeRangeW, formatTimeW, utcToLocalTime, localTimeToUTCSimple)
import Handler.Utils.Widgets (roomReferenceWidget)

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


data SlotAssociation
  = SlotIntersects -- ^ Slot is true subset of event
  | SlotEnds       -- ^ Event ends in slot, but does not begin within
  | SlotBegins     -- ^ Event begins in slot, but does not end within
  | SlotContained  -- ^ Event starts and ends within slot
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
  deriving anyclass (Universe, Finite)
nullaryPathPiece ''SlotAssociation $ camelToPathPiece' 1

_SlotAssociation :: Iso' SlotAssociation (Bool, Bool)
_SlotAssociation = iso toBools fromBools
  where
    toBools = \case
      SlotIntersects -> (False, False)
      SlotEnds       -> (False, True )
      SlotBegins     -> (True,  False)
      SlotContained  -> (True,  True )
    fromBools = \case
      (False, False) -> SlotIntersects
      (False, True ) -> SlotEnds
      (True,  False) -> SlotBegins
      (True,  True ) -> SlotContained

slotAssocIsCont :: SlotAssociation -> Bool
slotAssocIsCont = views (_SlotAssociation . _1) not


weekOffsets :: UTCTime -> Entity User -> ScheduleOffset -> [ScheduleOffset]
weekOffsets now user@(Entity _ User{userScheduleWeekDays = ScheduleWeekDays userScheduleWeekDays}) scheduleOffset
  = nub [ ScheduleOffsetDays (-7)
        , ScheduleOffsetDays $ go (-1)
        , ScheduleOffsetNone
        , ScheduleOffsetDays $ go 1
        , ScheduleOffsetDays 7
        ]
  where
    go d
      | weeksEqual 0 d
      , abs d < 7
      = go d'
      | d >= 0
      , abs d < 7
      , weeksEqual d d'
      = go d'
      | otherwise
      = d
      where d' = bool pred succ (d >= 0) d
    weeksEqual = on (==) $ filter (\d' -> dayOfWeek d' `elem` userScheduleWeekDays) . week
      where week d = weekDays now user $ ScheduleOffsetDays d `addOffset` scheduleOffset

weekDays :: UTCTime -> Entity User -> ScheduleOffset -> [Day]
weekDays now (Entity _ User{userWeekStart}) scheduleOffset = go dayNowOffset
  where go d
          | dayOfWeek d == firstDay = [d .. addDays 6 d]
          | otherwise = go $ pred d
        firstDay = toEnum $ fromEnum userWeekStart + offsetInDays scheduleOffset
        dayNowOffset = toInteger (offsetInDays scheduleOffset) `addDays` localDay (utcToLocalTime now)

  
weekSchedule :: UTCTime -> Entity User -> ScheduleOffset -> Widget
weekSchedule now user@(Entity uid User{userScheduleWeekDays = ScheduleWeekDays userScheduleWeekDays, ..}) scheduleOffset = do
  ata <- getSessionActiveAuthTags
  let localNow = utcToLocalTime now

  let
    dayNowOffset = toInteger (offsetInDays scheduleOffset) `addDays` localDay (utcToLocalTime now)
    week = weekDays now user scheduleOffset
    lectureDay (Entity _ Term{..}) d = termLectureStart <= d && d <= termLectureEnd
                                    && d `notElem` termHolidays
    isToday d = d == localDay localNow
    isCurrentSlot = isInTimeSlot $ localTimeOfDay localNow
    isCurrentScheduleEntry d ts = \case
      ScheduleCourseEvent{sceOccurrence,sceNoOccur} -> not (localNow `Set.member` sceNoOccur) && case sceOccurrence of
        Left ExceptNoOccur{..} -> localNow /= exceptTime  -- TODO: sceNoOccur and Left ExceptNoOccur{..} seem to be the same case
        Left ExceptOccur{..} -> d == exceptDay && timeOfDayToUTC exceptStart <= now && now < timeOfDayToUTC exceptEnd
        Right ScheduleWeekly{..} -> scheduleDayOfWeek == dayOfWeek d && timeOfDayToUTC scheduleStart <= now && now < timeOfDayToUTC scheduleEnd
      ScheduleTutorial{stOccurrence,stNoOccur} -> not (localNow `Set.member` stNoOccur) && case stOccurrence of
        Left ExceptNoOccur{..} -> localNow /= exceptTime  -- TODO: sceNoOccur and Left ExceptNoOccur{..} seem to be the same case
        Left ExceptOccur{..} -> d == exceptDay && timeOfDayToUTC exceptStart <= now && now < timeOfDayToUTC exceptEnd
        Right ScheduleWeekly{..} -> scheduleDayOfWeek == dayOfWeek d && timeOfDayToUTC scheduleStart <= now && now < timeOfDayToUTC scheduleEnd
      ScheduleExamOccurrence{seoStart,seoEnd} -> seoStart <= now && now < (fromMaybe (view _2 $ timeSlotToUTCTime d ts) seoEnd)
      where
        timeOfDayToUTC = localTimeToUTCSimple . LocalTime d

  (activeTerms, courseEvents, tutorials, examOccurrences) <- liftHandler . runDB $ (,,,)
    <$> fetchActiveTerms
    -- TODO: fetch course events for this week only?
    <*> fetchCourseEventsScheduleInfo (Just uid) ata now
    <*> fetchTutorialsScheduleInfo (Just uid) ata now
    -- TODO: this makes the exam table partly redundant => maybe remove?
    <*> fetchExamOccurrencesScheduleInfo (Just uid) ata now
  
  let
    holidays = concatMap (termHolidays . entityVal) activeTerms

    courseEventToScheduleEntries :: ScheduleCourseEventInfo -> [ScheduleEntry]
    courseEventToScheduleEntries (sceCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType=sceType,courseEventRoom=sceRoom,courseEventTime=Occurrences{..}}, E.Value sceShowRoom)
      | [sceTerm] <- filter ((== courseTerm) . entityKey) activeTerms
      , termActive $ entityVal sceTerm
      = let scheduleds
              = Set.toList occurrencesScheduled  <&> \scheduled ->
                  let sceOccurrence = Right scheduled in ScheduleCourseEvent{..}
            exceptions
              = Set.toList occurrencesExceptions <&> \exception ->
                  let sceOccurrence = Left  exception in ScheduleCourseEvent{..}
            sceNoOccur = setOf (folded . _ExceptNoOccur) occurrencesExceptions
         in scheduleds <> exceptions
      | otherwise = mempty

    tutorialToScheduleEntries :: ScheduleTutorialInfo -> [ScheduleEntry]
    tutorialToScheduleEntries (stCourse@(Entity _ Course{..}), Entity _ Tutorial{tutorialName=stName,tutorialType=stType,tutorialRoom=stRoom,tutorialTime=Occurrences{..}}, E.Value stShowRoom)
      | [stTerm] <- filter ((== courseTerm) . entityKey) activeTerms
      , termActive $ entityVal stTerm
      = let scheduleds
              = Set.toList occurrencesScheduled  <&> \scheduled ->
                  let stOccurrence = Right scheduled in ScheduleTutorial{..}
            exceptions
              = Set.toList occurrencesExceptions <&> \exception ->
                  let stOccurrence = Left  exception in ScheduleTutorial{..}
            stNoOccur = setOf (folded . _ExceptNoOccur) occurrencesExceptions
         in scheduleds <> exceptions
      | otherwise
      = mempty

    joinParallelExamOccurrences :: [ScheduleExamOccurrenceInfo] -> [ScheduleExamOccurrenceJoinedInfo]
    joinParallelExamOccurrences = go [] where
      go acc [] = acc
      go acc (examOcc@(course, exam, occ, showRoom):examOccs) =
        let ((((\(_,_,o,s) -> (o,s)) <$>) -> parallel), other) = partition (examOcc `isParallelTo`) examOccs
        in  go ((course, exam, (occ,showRoom):|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 :: ScheduleExamOccurrenceJoinedInfo -> ScheduleEntry
    examOccurrenceToScheduleEntry (seoCourse@(Entity _ Course{}), Entity _ Exam{examName=seoExamName}, examOccs@((Entity _ occ, _):|_)) =
      let seoRooms = (Set.fromList . toList) $ (\(Entity _ ExamOccurrence{examOccurrenceRoom}, E.Value showRoom) -> (examOccurrenceRoom, showRoom)) <$> 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{..}
    
    events'' :: Map Day (Map TimeSlot [(ScheduleEntry, SlotAssociation)])
    events'' = Map.fromList $ week <&> \d ->
      ( d
      , Map.fromList $ allTimeSlots <&> \slot ->
        ( slot
        , mapMaybe (\entry -> (entry, ) <$> seIsInSlot d slot entry) scheduleEntries
        )
      ) where
        scheduleEntries = join $ (courseEventToScheduleEntries  <$> courseEvents)
                         <>      (tutorialToScheduleEntries     <$> tutorials)
                         <> pure (examOccurrenceToScheduleEntry <$> (joinParallelExamOccurrences examOccurrences))

    events' :: Map Day (Map TimeSlot [(ScheduleEntry, SlotAssociation)])
    events' = flip imap events'' $ \currentDay 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 noOccurs term = \case
                Right ScheduleWeekly{..} -> and
                  [ lectureDay term currentDay
                  , flip none noOccurs $
                      \needle -> let localDay = scheduleDayOfWeek `dayOfWeekToDayWith` dayNowOffset
                                  in    LocalTime{ localDay, localTimeOfDay = scheduleStart } <= needle
                                     && needle <= LocalTime{ localDay, localTimeOfDay = scheduleEnd }
                  ]
                Left ExceptOccur{} -> True
                -- remove NoOccur exceptions
                Left ExceptNoOccur{} -> False
          in \case
            ScheduleCourseEvent{..} -> goPrune sceNoOccur sceTerm sceOccurrence
            ScheduleTutorial{..}    -> goPrune stNoOccur  stTerm  stOccurrence
            _ -> True
      in sortOn (views _1 $ scheduleEntryToStart currentDay) $ filter (views _1 isRegularWithoutException) occurrencesInSlot

    -- TODO: perform this filtering asap, in DB fetch if possible
    events :: Map Day (Map TimeSlot [(ScheduleEntry, SlotAssociation)])
    events = Map.filterWithKey shouldBeDisplayedOrHasEvents events' where
      shouldBeDisplayedOrHasEvents d entries = dayOfWeek d `elem` userScheduleWeekDays || any (not . null) entries

    timeSlotsDefaultDisplay :: Set TimeSlot
    timeSlotsDefaultDisplay = Set.fromList $ timeSlotsFromTo userScheduleWeekTimeslotLength userScheduleWeekTimeFrom userScheduleWeekTimeTo

    allTimeSlots :: [TimeSlot]
    allTimeSlots = timeSlotsAll userScheduleWeekTimeslotLength userScheduleWeekTimeFrom

    timeSlotIsEmpty :: TimeSlot -> Bool
    timeSlotIsEmpty slot = foldr (\d acc -> acc && maybe True null (d Map.!? slot)) True events

  $(widgetFile "schedule/week")


-- Local helper functions

-- | Check whether a given ScheduleEntry lies in a given TimeSlot
seIsInSlot :: Day -> TimeSlot -> ScheduleEntry -> Maybe SlotAssociation
seIsInSlot d slot = \case
    ScheduleCourseEvent{sceOccurrence} -> occurrenceIsInSlot sceOccurrence
    ScheduleTutorial{stOccurrence}     -> occurrenceIsInSlot stOccurrence
    ScheduleExamOccurrence{seoStart, seoEnd = Nothing}
      -> let associated = slotBegin <= seoStart && seoStart < slotEnd
          in guardOn associated SlotBegins
    ScheduleExamOccurrence{seoStart, seoEnd = Just seoEnd}
      -> let associated = seoEnd > slotBegin && seoStart < slotEnd
          in guardOn associated $ _SlotAssociation # ( slotBegin <= seoStart && seoStart <  slotEnd
                                                     , slotBegin <= seoEnd   && seoEnd   <= slotEnd
                                                     )
  where
    (slotBegin, slotEnd) = timeSlotToUTCTime d slot
    occurrenceIsInSlot occurrence = guardOn associated $ _SlotAssociation # ( slotBegin <= occStart && occStart <  slotEnd
                                                                            , slotBegin <= occEnd   && occEnd   <= slotEnd
                                                                            )
      where
        associated = occEnd > slotBegin && occStart < slotEnd
        occStart = localTimeToUTCSimple $ LocalTime occDay occStartTime
        occEnd   = localTimeToUTCSimple $ LocalTime occDay occEndTime
        (occDay, occStartTime, occEndTime) = case occurrence of
          Right ScheduleWeekly{..} -> (scheduleDayOfWeek `dayOfWeekToDayWith` d, scheduleStart, scheduleEnd)
          Left ExceptOccur{..} -> (exceptDay, exceptStart, exceptEnd)
          Left ExceptNoOccur{exceptTime=LocalTime{..}} -> (localDay, localTimeOfDay, localTimeOfDay)

-- | 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

scheduleEntryToStart :: Day -> ScheduleEntry -> UTCTime
scheduleEntryToStart currentDay = \case
  ScheduleCourseEvent{sceOccurrence} -> occurrenceToStart sceOccurrence
  ScheduleTutorial{stOccurrence}     -> occurrenceToStart stOccurrence
  ScheduleExamOccurrence{seoStart}   -> seoStart
  where
    occurrenceToStart = \case
      Left ExceptOccur{exceptDay, exceptStart} -> localTimeToUTCSimple $ LocalTime exceptDay exceptStart
      Left ExceptNoOccur{exceptTime}           -> localTimeToUTCSimple exceptTime
      Right ScheduleWeekly{scheduleStart}      -> localTimeToUTCSimple $ LocalTime currentDay scheduleStart

-- | 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 d | weekDay' == weekDay = d
       | weekDay' >  weekDay = go $ pred d
       | otherwise           = go $ succ d
       where weekDay' = dayOfWeek d

indexedList :: [a] -> [(Int, a)]
indexedList = zip [0..]
