fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

refactor(schedule): move SlotAssociation, move weekDays

Browse Source
This commit is contained in:
Sarah Vaupel 2021-05-06 14:35:34 +02:00
parent 0c8de277d5
commit e4ba4414c6
2 changed files with 43 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
src/Utils/Schedule/Week.hs
View File

@ -16,36 +16,10 @@ import Handler.Utils.Widgets (roomReferenceWidget)
import Utils.Schedule
import Utils.Schedule.Types
import Utils.Schedule.Week.SlotAssociation
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)
@ -69,15 +43,7 @@ weekOffsets now user@(Entity _ User{userScheduleWeekDays = ScheduleWeekDays user
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
@ -214,6 +180,14 @@ weekSchedule now user@(Entity uid User{userScheduleWeekDays = ScheduleWeekDays u
-- Local helper functions
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)
-- | Check whether a given ScheduleEntry lies in a given TimeSlot
seIsInSlot :: Day -> TimeSlot -> ScheduleEntry -> Maybe SlotAssociation
seIsInSlot d slot = \case

34
src/Utils/Schedule/Week/SlotAssociation.hs Normal file
View File

@ -0,0 +1,34 @@
module Utils.Schedule.Week.SlotAssociation
( SlotAssociation(..)
, _SlotAssociation
, slotAssocIsCont
) where
import Import
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