fix(schedule): improve offset behaviour
This commit is contained in:
Gregor Kleen
parent
ff9916fde6
commit
dba0891000
@ -135,9 +135,9 @@ ScheduleOccurrenceDisplayDefault: Termine standardmäßig darstellen
|
||||
ScheduleOccurrenceDisplayDefaultTip: Wenn gesetzt werden Termine zu Kursen, zu denen Sie sich anmelden nach erfolgter Anmeldung standardmäßig in Ihrer Terminübersicht dargestellt. Sie können die standardmäßige Darstellung pro Kurs und auch pro Einzeltermin überschreiben.
|
||||
|
||||
ScheduleOffsetWeekBackwardWeek: 1 Woche zurück
|
||||
ScheduleOffsetWeekBackwardDay: 1 Tag zurück
|
||||
ScheduleOffsetWeekBackwardDays n@Int: #{n} #{pluralDE n "Tag" "Tage"} zurück
|
||||
ScheduleOffsetWeekCurrent: Zu aktueller Woche springen
|
||||
ScheduleOffsetWeekForwardDay: 1 Tag vorwärts
|
||||
ScheduleOffsetWeekForwardDays n@Int: #{n} #{pluralDE n "Tag" "Tage"} vorwärts
|
||||
ScheduleOffsetWeekForwardWeek: 1 Woche vorwärts
|
||||
|
||||
ScheduleOptActions: Terminübersicht
|
||||
|
||||
@ -136,9 +136,9 @@ ScheduleOccurrenceDisplayDefault: Display occurrences by default
|
||||
ScheduleOccurrenceDisplayDefaultTip: When set, occurrences from courses you register for are displayed in your schedule by default after registration. You may override the default display per course and also per single occurrence.
|
||||
|
||||
ScheduleOffsetWeekBackwardWeek: 1 week back
|
||||
ScheduleOffsetWeekBackwardDay: 1 day back
|
||||
ScheduleOffsetWeekBackwardDays n: #{n} #{pluralEN n "day" "days"} back
|
||||
ScheduleOffsetWeekCurrent: Jump to current week
|
||||
ScheduleOffsetWeekForwardDay: 1 day forward
|
||||
ScheduleOffsetWeekForwardDays n: #{n} #{pluralEN n "day" "days"} forward
|
||||
ScheduleOffsetWeekForwardWeek: 1 week forward
|
||||
|
||||
ScheduleOptActions: Schedule
|
||||
|
||||
@ -90,7 +90,10 @@ newsSystemMessages = do
|
||||
|
||||
-- TODO: deprecated; update once ScheduleR is finished
|
||||
newsSchedule :: Entity User -> Widget
|
||||
newsSchedule user = let schedule = weekSchedule user ScheduleOffsetNone in $(widgetFile "news/schedule")
|
||||
newsSchedule user = do
|
||||
now <- liftIO getCurrentTime
|
||||
let schedule = weekSchedule now user ScheduleOffsetNone
|
||||
$(widgetFile "news/schedule")
|
||||
|
||||
|
||||
newsUpcomingSheets :: UserId -> Widget
|
||||
|
||||
@ -14,6 +14,7 @@ import Utils.Schedule.Week
|
||||
getScheduleR, postScheduleR :: Handler Html
|
||||
getScheduleR = postScheduleR
|
||||
postScheduleR = do
|
||||
now <- liftIO getCurrentTime
|
||||
user@(Entity _uid User{userScheduleView}) <- requireAuth
|
||||
|
||||
-- TODO: local instead of global get params?
|
||||
@ -58,22 +59,21 @@ postScheduleR = do
|
||||
|
||||
let
|
||||
offsetBtns = case viewRes of
|
||||
FormSuccess ScheduleOptions{scheduleView=ScheduleViewWeek} -> [ ScheduleOffsetDays (-7)
|
||||
, ScheduleOffsetDays (-1)
|
||||
, ScheduleOffsetNone
|
||||
, ScheduleOffsetDays 1
|
||||
, ScheduleOffsetDays 7
|
||||
] <&> (\sNewOffset -> currentScheduleOptions
|
||||
{ scheduleOffset = case sNewOffset of
|
||||
ScheduleOffsetNone -> ScheduleOffsetNone
|
||||
_ -> (scheduleOffset currentScheduleOptions) `addOffset` sNewOffset
|
||||
, scheduleOptionsAction = ScheduleSetOffset sNewOffset
|
||||
})
|
||||
FormSuccess ScheduleOptions{scheduleView=ScheduleViewWeek}
|
||||
-> weekOffsets now user (scheduleOffset currentScheduleOptions)
|
||||
<&> (\sNewOffset -> currentScheduleOptions
|
||||
{ scheduleOffset = case sNewOffset of
|
||||
ScheduleOffsetNone -> ScheduleOffsetNone
|
||||
_ -> scheduleOffset currentScheduleOptions `addOffset` sNewOffset
|
||||
, scheduleOptionsAction = ScheduleSetOffset sNewOffset
|
||||
})
|
||||
_ -> mempty
|
||||
|
||||
(offsetRess, offsetWidgets) <- fmap unzip . for offsetBtns $ \btn ->
|
||||
mopt (buttonFieldNoParse btn) ("" { fsName = Just $ toPathPiece GetScheduleOptions
|
||||
, fsAttrs = if offsetInDays (scheduleOffset btn) == offsetInDays (scheduleOffset currentScheduleOptions) then [("disabled","")] else mempty
|
||||
, fsAttrs = if ((==) `on `offsetInDays) (scheduleOffset btn) (scheduleOffset currentScheduleOptions)
|
||||
then [("disabled","")]
|
||||
else mempty
|
||||
}) Nothing
|
||||
offsetRes <- if
|
||||
| Just errs <- fromNullable (filter (is _FormFailure) offsetRess) -> do
|
||||
@ -95,7 +95,7 @@ postScheduleR = do
|
||||
((optionsRes, optionsWidget), optionsEnctype) <- runFormGet scheduleOptionsForm
|
||||
|
||||
schedule <- case optionsRes of
|
||||
FormSuccess ScheduleOptions{scheduleView=ScheduleViewWeek,..} -> return $ weekSchedule user scheduleOffset
|
||||
FormSuccess ScheduleOptions{scheduleView=ScheduleViewWeek,..} -> return $ weekSchedule now user scheduleOffset
|
||||
other -> formFailure2Alerts other >> return mempty
|
||||
|
||||
let scheduleExplanation = $(i18nWidgetFile "schedule-explanation")
|
||||
@ -103,15 +103,3 @@ postScheduleR = do
|
||||
siteLayoutMsg MsgMenuSchedule $ do
|
||||
setTitleI MsgMenuSchedule
|
||||
$(widgetFile "schedule")
|
||||
|
||||
|
||||
-- | Join two ScheduleOffsets by addition
|
||||
addOffset :: ScheduleOffset -> ScheduleOffset -> ScheduleOffset
|
||||
addOffset ScheduleOffsetNone offset = offset
|
||||
addOffset offset ScheduleOffsetNone = offset
|
||||
addOffset (ScheduleOffsetDays d) (ScheduleOffsetDays d') = ScheduleOffsetDays $ d + d'
|
||||
|
||||
-- | Calculate number of offset days from ScheduleOffset
|
||||
offsetInDays :: ScheduleOffset -> Int
|
||||
offsetInDays ScheduleOffsetNone = 0
|
||||
offsetInDays (ScheduleOffsetDays d) = d
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
module Utils.Schedule.Types.ScheduleOffset
|
||||
( ScheduleOffset(..)
|
||||
, addOffset, offsetInDays
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
@ -10,3 +11,15 @@ data ScheduleOffset = ScheduleOffsetNone
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
|
||||
derivePathPiece ''ScheduleOffset (camelToPathPiece' 1) "_"
|
||||
|
||||
|
||||
-- | Join two ScheduleOffsets by addition
|
||||
addOffset :: ScheduleOffset -> ScheduleOffset -> ScheduleOffset
|
||||
addOffset ScheduleOffsetNone offset = offset
|
||||
addOffset offset ScheduleOffsetNone = offset
|
||||
addOffset (ScheduleOffsetDays d) (ScheduleOffsetDays d') = ScheduleOffsetDays $ d + d'
|
||||
|
||||
-- | Calculate number of offset days from ScheduleOffset
|
||||
offsetInDays :: ScheduleOffset -> Int
|
||||
offsetInDays ScheduleOffsetNone = 0
|
||||
offsetInDays (ScheduleOffsetDays d) = d
|
||||
|
||||
@ -31,16 +31,14 @@ derivePathPiece ''ScheduleOptions (camelToPathPiece' 1) "---"
|
||||
instance Button UniWorX ScheduleOptions where
|
||||
btnClasses = const [BCIsButton]
|
||||
btnLabel ScheduleOptions{..} = case scheduleOptionsAction of
|
||||
ScheduleSetDefault -> [whamlet| _{MsgScheduleReset} |]
|
||||
ScheduleSetDefault -> i18n MsgScheduleReset
|
||||
ScheduleSetView -> case scheduleView of
|
||||
ScheduleViewWeek -> [whamlet| _{MsgScheduleViewWeek} |]
|
||||
ScheduleViewWeek -> i18n MsgScheduleViewWeek
|
||||
ScheduleSetOffset o -> case scheduleView of
|
||||
ScheduleViewWeek -> let iconTooltipMessage i m = iconTooltip [whamlet| _{m} |] (Just i) True in case o of
|
||||
ScheduleOffsetNone -> [whamlet| ^{iconTooltipMessage IconCurrent MsgScheduleOffsetWeekCurrent} |]
|
||||
ScheduleOffsetDays d -> case d of
|
||||
(-7) -> [whamlet| ^{iconTooltipMessage IconFastBackward MsgScheduleOffsetWeekBackwardWeek} |]
|
||||
(-1) -> [whamlet| ^{iconTooltipMessage IconBackward MsgScheduleOffsetWeekBackwardDay} |]
|
||||
0 -> [whamlet| ^{iconTooltipMessage IconCurrent MsgScheduleOffsetWeekCurrent} |]
|
||||
1 -> [whamlet| ^{iconTooltipMessage IconForward MsgScheduleOffsetWeekForwardDay} |]
|
||||
7 -> [whamlet| ^{iconTooltipMessage IconFastForward MsgScheduleOffsetWeekForwardWeek} |]
|
||||
_ -> [whamlet| #{tshow d} |]
|
||||
ScheduleViewWeek -> let iconTooltipMessage i m = iconTooltip (i18n m) (Just i) True
|
||||
o' = offsetInDays o
|
||||
in if | o' <= (-7) -> iconTooltipMessage IconFastBackward MsgScheduleOffsetWeekBackwardWeek
|
||||
| o' < 0 -> iconTooltipMessage IconBackward . MsgScheduleOffsetWeekBackwardDays $ abs o'
|
||||
| o' == 0 -> iconTooltipMessage IconCurrent MsgScheduleOffsetWeekCurrent
|
||||
| o' < 7 -> iconTooltipMessage IconForward . MsgScheduleOffsetWeekForwardDays $ abs o'
|
||||
| otherwise -> iconTooltipMessage IconFastForward MsgScheduleOffsetWeekForwardWeek
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
module Utils.Schedule.Week
|
||||
( weekSchedule
|
||||
( weekOffsets, weekSchedule
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -18,9 +18,43 @@ import Utils.Schedule.Types
|
||||
import Utils.Schedule.Week.TimeSlot
|
||||
|
||||
|
||||
weekSchedule :: Entity User -> ScheduleOffset -> Widget
|
||||
weekSchedule (Entity uid User{userScheduleWeekDays=ScheduleWeekDays userScheduleWeekDays,..}) scheduleOffset = do
|
||||
now <- liftIO getCurrentTime
|
||||
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 + dayOffset
|
||||
dayNowOffset = toInteger dayOffset `addDays` utctDay now
|
||||
dayOffset = case scheduleOffset of
|
||||
ScheduleOffsetNone -> 0
|
||||
ScheduleOffsetDays d -> d
|
||||
|
||||
|
||||
weekSchedule :: UTCTime -> Entity User -> ScheduleOffset -> Widget
|
||||
weekSchedule now user@(Entity uid User{userScheduleWeekDays = ScheduleWeekDays userScheduleWeekDays, ..}) scheduleOffset = do
|
||||
ata <- getSessionActiveAuthTags
|
||||
|
||||
let
|
||||
@ -28,6 +62,7 @@ weekSchedule (Entity uid User{userScheduleWeekDays=ScheduleWeekDays userSchedule
|
||||
ScheduleOffsetNone -> 0
|
||||
ScheduleOffsetDays d -> d
|
||||
dayNowOffset = toInteger dayOffset `addDays` utctDay now
|
||||
week = weekDays now user scheduleOffset
|
||||
|
||||
-- TODO: single runDB for all fetches below?
|
||||
|
||||
@ -116,13 +151,6 @@ weekSchedule (Entity uid User{userScheduleWeekDays=ScheduleWeekDays userSchedule
|
||||
events = Map.filterWithKey shouldBeDisplayedOrHasEvents events' where
|
||||
shouldBeDisplayedOrHasEvents d entries = dayOfWeek d `elem` userScheduleWeekDays || any (not . null) entries
|
||||
|
||||
week :: [Day]
|
||||
week = go dayNowOffset
|
||||
where go d
|
||||
| dayOfWeek d == firstDay = [d .. toEnum (fromEnum d + 6)]
|
||||
| otherwise = go $ pred d
|
||||
firstDay = toEnum $ fromEnum userWeekStart + dayOffset
|
||||
|
||||
-- TODO: avoid overlaps wrt. timeslot length (FIXME!!)
|
||||
timeSlotsDefaultDisplay :: Set TimeSlot
|
||||
timeSlotsDefaultDisplay = Set.fromList $ timeSlotsFromTo userScheduleWeekTimeslotLength userScheduleWeekTimeFrom userScheduleWeekTimeTo
|
||||
|
||||
Reference in New Issue
Block a user