refactor(schedule): (type) cleanup
This commit is contained in:
Gregor Kleen
parent
22f43a9631
commit
ff9916fde6
@ -214,11 +214,11 @@ user-defaults:
|
||||
download-files: false
|
||||
warning-days: 1209600
|
||||
show-sex: false
|
||||
schedule-view: view-week
|
||||
schedule-view: week
|
||||
schedule-week-days: [Monday,Tuesday,Wednesday,Thursday,Friday]
|
||||
schedule-week-time-from: 8
|
||||
schedule-week-time-to: 18
|
||||
schedule-week-timeslot-length: 2
|
||||
schedule-week-time-from: 28800 # 08:00
|
||||
schedule-week-time-to: 72000 # 20:00
|
||||
schedule-week-timeslot-length: 7200 # 2h
|
||||
schedule-occurrence-display-default: true
|
||||
|
||||
# During central allocations lecturer-given ratings of applications (as
|
||||
|
||||
@ -115,14 +115,14 @@ ProfileScheduleViewTip: Betrifft die Terminübersicht auf „Aktuelles“ und
|
||||
|
||||
ScheduleWeekDays: In der Wochenansicht dargestellte Wochentage
|
||||
ScheduleWeekDaysTip: Wochentage, welche standardmäßig in der Wochenansicht dargestellt werden. Gibt es einen darzustellenden Termin, der auf einen Wochentag fällt welcher hier nicht gesetzt ist, so wird der jeweilige Wochentag als zusätzliche Spalte angezeigt.
|
||||
ScheduleWeekTimeFrom: Beginn (Stunde) des ersten in der Wochenansicht dargestellten Zeitslots
|
||||
ScheduleWeekTimeFromTip: Stunde, zu welcher der erste in der Wochenansicht dargestellte Zeitslot beginnt. Gibt es einen darzustellenden Termin, der in einem Zeitslot vor dem hier angegebenen Zeitslot liegt, so wird der jeweilige Zeitslot als zusätzliche Zeile vor dem hier angegeben Zeitslot angezeigt.
|
||||
ScheduleWeekTimeFrom: Beginn des ersten in der Wochenansicht dargestellten Zeitslots
|
||||
ScheduleWeekTimeFromTip: Zeitpunkt, zu welchem der erste in der Wochenansicht dargestellte Zeitslot beginnt. Gibt es einen darzustellenden Termin, der in einem Zeitslot vor dem hier angegebenen Zeitslot liegt, so wird der jeweilige Zeitslot als zusätzliche Zeile vor dem hier angegeben Zeitslot angezeigt.
|
||||
ScheduleWeekTimeFromPlaceholder: Erster Zeitslot
|
||||
ScheduleWeekTimeTo: Beginn (Stunde) des letzten in der Wochenansicht dargestellten Zeitslots
|
||||
ScheduleWeekTimeToTip: Stunde, zu welcher der letzte in der Wochenansicht dargestellte Zeitslot beginnt. Gibt es einen darzustellenden Termin, der in einem Zeitslot nach dem hier angegebenen Zeitslot liegt, so wird der jeweilige Zeitslot als zusätzliche Zeile nach dem hier angegebenen Zeitslot angezeigt.
|
||||
ScheduleWeekTimeTo: Ende des letzten in der Wochenansicht dargestellten Zeitslots
|
||||
ScheduleWeekTimeToTip: Zeitpunkt, zu welchem der letzte in der Wochenansicht dargestellte Zeitslot endet. Gibt es einen darzustellenden Termin, der in einem Zeitslot nach dem hier angegebenen Zeitslot liegt, so wird der jeweilige Zeitslot als zusätzliche Zeile nach dem hier angegebenen Zeitslot angezeigt.
|
||||
ScheduleWeekTimeToPlaceholder: Letzter Zeitslot
|
||||
ScheduleWeekTimeslotLength: Länge (in Stunden) der in der Wochenansicht dargestellten Zeitslots
|
||||
ScheduleWeekTimeslotLengthTip: Die Länge (in Stunden) jedes in der Wochenansicht der Terminübersicht als separate Zeile dargestellten Zeitslots
|
||||
ScheduleWeekTimeslotLength: Länge (in Minuten) der in der Wochenansicht dargestellten Zeitslots
|
||||
ScheduleWeekTimeslotLengthTip: Die Länge (in Minuten) jedes in der Wochenansicht der Terminübersicht als separate Zeile dargestellten Zeitslots
|
||||
ScheduleWeekTimeslotLengthPlaceholder: Zeitslotlänge
|
||||
|
||||
ScheduleWeekTimeFromMustBeAValidTime n@Int: Erster Zeitslot der Wochenansicht muss zwischen 0 und #{n} liegen
|
||||
|
||||
@ -116,14 +116,14 @@ ProfileScheduleViewTip: Relevant for the schedule on "News" and "Schedule". (Mor
|
||||
|
||||
ScheduleWeekDays: Weekdays to display in the weekly schedule
|
||||
ScheduleWeekDaysTip: Weekdays to display by default in the weekly schedule. If there is an occurrence to display which occurs on a weekday that is not set here, the weekday will be displayed as a separate column regardless.
|
||||
ScheduleWeekTimeFrom: Start (hour) of the first timeslot to display in the weekly schedule
|
||||
ScheduleWeekTimeFromTip: The hour at which the first timeslot to display in the weekly schedule begins. If there is an occurrence to display which lies in a timeslot before the one given here, the respective timeslot will be displayed above this one as a separate row.
|
||||
ScheduleWeekTimeFrom: Start of the first timeslot to display in the weekly schedule
|
||||
ScheduleWeekTimeFromTip: The time of day at which the first timeslot to display in the weekly schedule begins. If there is an occurrence to display which lies in a timeslot before the one given here, the respective timeslot will be displayed above this one as a separate row.
|
||||
ScheduleWeekTimeFromPlaceholder: First timeslot
|
||||
ScheduleWeekTimeTo: Start (hour) of the last timeslot to display in the weekly schedule
|
||||
ScheduleWeekTimeToTip: The hour at which the last timeslot to display in the weekly schedule begins. If there is an occurrence to display which lies in a timeslot after the one given here, the respective timeslot will be displayed below this one as a separate row.
|
||||
ScheduleWeekTimeTo: End of the last timeslot to display in the weekly schedule
|
||||
ScheduleWeekTimeToTip: The time of day at which the last timeslot to display in the weekly schedule ends. If there is an occurrence to display which lies in a timeslot after the one given here, the respective timeslot will be displayed below this one as a separate row.
|
||||
ScheduleWeekTimeToPlaceholder: Last timeslot
|
||||
ScheduleWeekTimeslotLength: Length (in hours) of timeslots to display in the weekly schedule
|
||||
ScheduleWeekTimeslotLengthTip: The length (in hours) of each timeslot to display as a separate row in the weekly schedule
|
||||
ScheduleWeekTimeslotLength: Length (in minutes) of timeslots to display in the weekly schedule
|
||||
ScheduleWeekTimeslotLengthTip: The length (in minutes) of each timeslot to display as a separate row in the weekly schedule
|
||||
ScheduleWeekTimeslotLengthPlaceholder: Timeslot length
|
||||
|
||||
ScheduleWeekTimeFromMustBeAValidTime n@Int: First timeslot to display in the weekly schedule must be between 0 and #{n}
|
||||
|
||||
@ -28,7 +28,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
||||
dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined
|
||||
dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined
|
||||
timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined
|
||||
weekStart DayOfWeek default='Monday' -- preferred first day of week for user; user-defined
|
||||
weekStart DayOfWeek default='monday' -- preferred first day of week for user; user-defined
|
||||
downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this)
|
||||
languages Languages Maybe -- Preferred language; user-defined
|
||||
notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined
|
||||
@ -36,11 +36,11 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
||||
csvOptions CsvOptions "default='{}'::jsonb"
|
||||
sex Sex Maybe
|
||||
showSex Bool default=false
|
||||
scheduleView ScheduleView default='ScheduleViewWeek'
|
||||
scheduleView ScheduleView default='week'
|
||||
scheduleWeekDays ScheduleWeekDays default='["monday","tuesday","wednesday","thursday","friday"]'::jsonb -- which weekdays to display by default; if there is an occurrence to display for a weekday that is not mentioned here, the weekday will be displayed regardless
|
||||
scheduleWeekTimeFrom Int default=8 -- starting hour of the first time slot to display in weekly schedule by default (i.e. regardless of the existence of occurrences in this slot); TODO: increase precision to minutes
|
||||
scheduleWeekTimeTo Int default=18 -- starting hour of the last time slot to display in weekly schedule by default (i.e. regardless of the existence of occurrences in this slot); TODO: increase precision to minutes; TODO: save last hour/minute to display instead of first (of last time slot)
|
||||
scheduleWeekTimeslotLength Int default=2 -- length of one timeslot in hours; TODO: increase precision to minutes
|
||||
scheduleWeekTimeFrom NominalDiffTime default=28800 -- start of the first time slot to display in weekly schedule by default (i.e. regardless of the existence of occurrences in this slot)
|
||||
scheduleWeekTimeTo NominalDiffTime default=72000 -- end of the last time slot to display in weekly schedule by default (i.e. regardless of the existence of occurrences in this slot)
|
||||
scheduleWeekTimeslotLength NominalDiffTime default=7200 -- length of one timeslot
|
||||
scheduleOccurrenceDisplayDefault Bool default=True -- whether occurrences from new courses should be displayed in the schedule by default
|
||||
UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table
|
||||
UniqueEmail email -- Column 'email' can be used as a row-key in this table
|
||||
|
||||
@ -39,9 +39,9 @@ data SettingsForm = SettingsForm
|
||||
, stgDisplayEmail :: UserEmail
|
||||
, stgScheduleView :: ScheduleView
|
||||
, stgScheduleWeekDays :: ScheduleWeekDays
|
||||
, stgScheduleWeekTimeFrom :: Int
|
||||
, stgScheduleWeekTimeTo :: Int
|
||||
, stgScheduleWeekTimeslotLength :: Int
|
||||
, stgScheduleWeekTimeFrom
|
||||
, stgScheduleWeekTimeTo :: NominalDiffTime
|
||||
, stgScheduleWeekTimeslotLength :: NominalDiffTime
|
||||
, stgScheduleOccurrenceDisplayDefault :: Bool
|
||||
, stgMaxFavourites :: Int
|
||||
, stgMaxFavouriteTerms :: Int
|
||||
@ -108,14 +108,16 @@ makeSettingForm template html = do
|
||||
<*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template)
|
||||
<*> areq (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template)
|
||||
<* aformSection MsgSchedule
|
||||
<*> areq (selectField . return $ mkOptionList (scheduleViewList mr))
|
||||
(fslI MsgProfileScheduleView & setTooltip MsgProfileScheduleViewTip) { fsId = Just "schedule-view-select" } (stgScheduleView <$> template)
|
||||
<*> (case universeF of
|
||||
[sOpt] -> pure sOpt -- Don't bother showing the select as long as there is only one option
|
||||
_other -> apopt (selectField optionsFinite) (fslI MsgProfileScheduleView & setTooltip MsgProfileScheduleViewTip) { fsId = Just "schedule-view-select" } (stgScheduleView <$> template)
|
||||
)
|
||||
<*> scheduleWeekDaysForm (stgScheduleWeekDays <$> template)
|
||||
<*> areq (natFieldI MsgScheduleWeekTimeFrom)
|
||||
<*> areq timeOfDayField
|
||||
(fslpI MsgScheduleWeekTimeFrom (mr MsgScheduleWeekTimeFromPlaceholder) & setTooltip MsgScheduleWeekTimeFromTip) (stgScheduleWeekTimeFrom <$> template)
|
||||
<*> areq (natFieldI MsgScheduleWeekTimeTo )
|
||||
<*> areq timeOfDayField
|
||||
(fslpI MsgScheduleWeekTimeTo (mr MsgScheduleWeekTimeToPlaceholder ) & setTooltip MsgScheduleWeekTimeToTip ) (stgScheduleWeekTimeTo <$> template)
|
||||
<*> areq (natFieldI MsgScheduleWeekTimeslotLength)
|
||||
<*> areq (convertField (fromInteger . (* 60)) ((`quot` 60) . round) $ posIntFieldI MsgScheduleWeekTimeslotLength)
|
||||
(fslpI MsgScheduleWeekTimeslotLength (mr MsgScheduleWeekTimeslotLengthPlaceholder) & setTooltip MsgScheduleWeekTimeslotLengthTip) (stgScheduleWeekTimeslotLength <$> template)
|
||||
<*> apopt checkBoxField (fslI MsgScheduleOccurrenceDisplayDefault & setTooltip MsgScheduleOccurrenceDisplayDefaultTip) (stgScheduleOccurrenceDisplayDefault <$> template)
|
||||
<* aformSection MsgFormCosmetics
|
||||
@ -128,7 +130,7 @@ makeSettingForm template html = do
|
||||
<*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
|
||||
<*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template)
|
||||
<*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template)
|
||||
<*> areq (selectField . return $ mkOptionList (weekDayList mr)) (fslI MsgWeekStart) (stgWeekStart <$> template)
|
||||
<*> areq (selectField optionsFinite) (fslI MsgWeekStart) (stgWeekStart <$> template)
|
||||
<* aformSection MsgFormBehaviour
|
||||
<*> apopt checkBoxField (fslI MsgDownloadFiles
|
||||
& setTooltip MsgDownloadFilesTip
|
||||
@ -143,31 +145,12 @@ makeSettingForm template html = do
|
||||
<*> allocationNotificationForm (stgAllocationNotificationSettings <$> template)
|
||||
return (result, widget)
|
||||
where
|
||||
scheduleViewList mr = [ Option (mr t) t (toPathPiece t) | t <- universeF ]
|
||||
themeList = [ Option (toMessage t) t (toPathPiece t) | t <- universeF ]
|
||||
weekDayList mr = [ Option (mr t) t (toPathPiece t) | t <- universeF ]
|
||||
|
||||
scheduleWeekDaysForm :: Maybe ScheduleWeekDays -> AForm Handler ScheduleWeekDays
|
||||
scheduleWeekDaysForm template = formToAForm $ scheduleWeekDaysView =<< renderWForm FormStandard scheduleWeekDaysForm' mempty
|
||||
where
|
||||
scheduleWeekDaysForm' :: WForm Handler (FormResult ScheduleWeekDays)
|
||||
scheduleWeekDaysForm' = do
|
||||
mr <- getMessageRender
|
||||
let allWeekDays = universeF
|
||||
weekDayForm wDay = fmap (ScheduleWeekDays . bool mempty [wDay]) <$> wpopt checkBoxField (fslI $ mr wDay) ((\(ScheduleWeekDays wDays) -> wDay `elem` wDays) <$> template)
|
||||
fold <$> mapM weekDayForm allWeekDays
|
||||
|
||||
scheduleWeekDaysView :: (FormResult ScheduleWeekDays, Widget) -> MForm Handler (FormResult ScheduleWeekDays, [FieldView UniWorX])
|
||||
scheduleWeekDaysView (res, fvInput) = do
|
||||
mr <- getMessageRender
|
||||
let fvLabel = toHtml $ mr MsgScheduleWeekDays
|
||||
fvTooltip = Just . toHtml $ mr MsgScheduleWeekDaysTip
|
||||
fvRequired = False
|
||||
fvErrors
|
||||
| FormFailure (err : _) <- res = Just $ toHtml err
|
||||
| otherwise = Nothing
|
||||
fvId <- newIdent
|
||||
return (res, pure FieldView{..})
|
||||
scheduleWeekDaysForm template' = prismAForm (_Wrapped . _IndicatorFunction) template' $ \template
|
||||
-> let dayForm wDay = apopt checkBoxField (fslI wDay) (template <&> ($ wDay))
|
||||
in funcForm dayForm (fslI MsgScheduleWeekDays & setTooltip MsgScheduleWeekDaysTip) False
|
||||
|
||||
schoolsForm :: Maybe (Set SchoolId) -> AForm Handler (Set SchoolId)
|
||||
schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandard schoolsForm' mempty
|
||||
@ -364,21 +347,11 @@ validateSettings User{..} = do
|
||||
guardValidation MsgUserDisplayNameInvalid $
|
||||
validDisplayName userTitle userFirstName userSurname userDisplayName'
|
||||
|
||||
userScheduleWeekTimeFrom' <- use _stgScheduleWeekTimeFrom
|
||||
userScheduleWeekTimeTo' <- use _stgScheduleWeekTimeTo
|
||||
userScheduleWeekTimeslotLength' <- use _stgScheduleWeekTimeslotLength
|
||||
userScheduleWeekTimeFrom' <- use _stgScheduleWeekTimeFrom
|
||||
userScheduleWeekTimeTo' <- use _stgScheduleWeekTimeTo
|
||||
|
||||
let maxFrom = 25 - userScheduleWeekTimeslotLength'
|
||||
guardValidation (MsgScheduleWeekTimeFromMustBeAValidTime maxFrom)
|
||||
$ 0 < userScheduleWeekTimeFrom' && userScheduleWeekTimeFrom' < maxFrom
|
||||
guardValidation MsgScheduleWeekTimeToMustBeAValidTime
|
||||
$ 0 < userScheduleWeekTimeTo' && userScheduleWeekTimeTo' < 25
|
||||
guardValidation MsgScheduleWeekTimeToMustBeAfterTimeFrom
|
||||
$ userScheduleWeekTimeTo' > userScheduleWeekTimeFrom'
|
||||
guardValidation MsgScheduleWeekTimeslotLengthMustBeGreaterZero
|
||||
$ userScheduleWeekTimeslotLength' > 0
|
||||
guardValidation MsgScheduleWeekTimeFromToMustMatchTimeslotLength
|
||||
$ userScheduleWeekTimeTo' `elem` [userScheduleWeekTimeFrom', userScheduleWeekTimeFrom'+userScheduleWeekTimeslotLength' .. 24-userScheduleWeekTimeslotLength']
|
||||
|
||||
|
||||
data ButtonResetTokens = BtnResetTokens
|
||||
|
||||
@ -1287,7 +1287,7 @@ dayTimeField fs mutc = do
|
||||
|
||||
fieldTimeFormat :: String
|
||||
-- fieldTimeFormat = "%e.%m.%y %k:%M"
|
||||
fieldTimeFormat = "%Y-%m-%dT%H:%M:%S"
|
||||
fieldTimeFormat = "%Y-%m-%dT%H:%M:%S%Q"
|
||||
|
||||
localTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m LocalTime
|
||||
localTimeField = Field
|
||||
|
||||
@ -992,6 +992,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|43.0.0|] [version|44.0.0|]
|
||||
, [executeQQ|
|
||||
SET client_min_messages TO WARNING;
|
||||
ALTER TABLE IF EXISTS ^{Allocation} ALTER COLUMN @{AllocationDescription} TYPE jsonb USING (CASE WHEN @{AllocationDescription} IS NOT NULL THEN to_json(@{AllocationDescription}) ELSE NULL END);
|
||||
ALTER TABLE IF EXISTS ^{Allocation} ALTER COLUMN @{AllocationStaffDescription} TYPE jsonb USING (CASE WHEN @{AllocationStaffDescription} IS NOT NULL THEN to_json(@{AllocationStaffDescription}) ELSE NULL END);
|
||||
ALTER TABLE IF EXISTS ^{Course} ALTER COLUMN @{CourseDescription} TYPE jsonb USING (CASE WHEN @{CourseDescription} IS NOT NULL THEN to_json(@{CourseDescription}) ELSE NULL END);
|
||||
@ -1009,6 +1010,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageSummary} IS NOT NULL THEN to_json(@{SystemMessageSummary}) ELSE NULL END);
|
||||
ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationContent} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationContent} IS NOT NULL THEN to_json(@{SystemMessageTranslationContent}) ELSE NULL END);
|
||||
ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationSummary} IS NOT NULL THEN to_json(@{SystemMessageTranslationSummary}) ELSE NULL END);
|
||||
SET client_min_messages TO NOTICE;
|
||||
|]
|
||||
)
|
||||
]
|
||||
|
||||
@ -21,6 +21,8 @@ import Web.HttpApiData
|
||||
|
||||
import Data.Aeson.Types as Aeson
|
||||
|
||||
import Model.Types.TH.PathPiece
|
||||
|
||||
|
||||
----
|
||||
-- Terms, Seaons, anything loosely related to time
|
||||
@ -189,3 +191,13 @@ derivePersistFieldJSON ''Occurrences
|
||||
|
||||
|
||||
nullaryPathPiece ''DayOfWeek camelToPathPiece
|
||||
derivePersistFieldPathPiece ''DayOfWeek
|
||||
|
||||
|
||||
newtype ScheduleWeekDays = ScheduleWeekDays (Set DayOfWeek)
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
|
||||
deriveJSON defaultOptions ''ScheduleWeekDays
|
||||
derivePersistFieldJSON ''ScheduleWeekDays
|
||||
makeWrapped ''ScheduleWeekDays
|
||||
|
||||
@ -28,7 +28,6 @@ import qualified Data.Aeson as JSON
|
||||
import Database.Persist.Sql (PersistFieldSql(..))
|
||||
|
||||
import Utils.Lens.TH
|
||||
import Utils.Schedule.Types.ScheduleView
|
||||
|
||||
import Web.HttpApiData
|
||||
|
||||
@ -281,22 +280,3 @@ instance ToHttpApiData TokenBucketIdent where
|
||||
toUrlPiece = toPathPiece
|
||||
instance FromHttpApiData TokenBucketIdent where
|
||||
parseUrlPiece = maybe (Left "Could not parse TokenBucketIdent") Right . fromPathPiece
|
||||
|
||||
|
||||
derivePersistField "DayOfWeek"
|
||||
|
||||
newtype ScheduleWeekDays = ScheduleWeekDays [DayOfWeek]
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Semigroup ScheduleWeekDays where
|
||||
ScheduleWeekDays w <> ScheduleWeekDays w' = ScheduleWeekDays $ w <> w'
|
||||
instance Monoid ScheduleWeekDays where
|
||||
mempty = ScheduleWeekDays mempty
|
||||
|
||||
deriveJSON defaultOptions ''ScheduleWeekDays
|
||||
derivePersistFieldJSON ''ScheduleWeekDays
|
||||
|
||||
|
||||
pathPieceJSON ''ScheduleView
|
||||
pathPieceJSONKey ''ScheduleView
|
||||
derivePersistField "ScheduleView"
|
||||
|
||||
@ -218,8 +218,8 @@ data UserDefaultConf = UserDefaultConf
|
||||
, userDefaultShowSex :: Bool
|
||||
, userDefaultScheduleView :: ScheduleView
|
||||
, userDefaultScheduleWeekDays :: ScheduleWeekDays
|
||||
, userDefaultScheduleWeekTimeFrom, userDefaultScheduleWeekTimeTo :: Int
|
||||
, userDefaultScheduleWeekTimeslotLength :: Int
|
||||
, userDefaultScheduleWeekTimeFrom, userDefaultScheduleWeekTimeTo :: NominalDiffTime
|
||||
, userDefaultScheduleWeekTimeslotLength :: NominalDiffTime
|
||||
, userDefaultScheduleOccurrenceDisplayDefault :: Bool
|
||||
} deriving (Show)
|
||||
|
||||
|
||||
15
src/Utils.hs
15
src/Utils.hs
@ -526,6 +526,21 @@ setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (previ
|
||||
setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k
|
||||
setFromFunc = Set.fromList . flip filter universeF
|
||||
|
||||
funcFromSet :: Ord k => Set k -> (k -> Bool)
|
||||
funcFromSet = flip Set.member
|
||||
|
||||
_IndicatorFunction :: (Finite k, Ord k) => Iso' (Set k) (k -> Bool)
|
||||
_IndicatorFunction = iso funcFromSet setFromFunc
|
||||
|
||||
setFromMap :: Map k Bool -> Set k
|
||||
setFromMap = Map.keysSet . Map.filter id
|
||||
|
||||
mapFromSet :: Set k -> Map k Bool
|
||||
mapFromSet = Map.fromSet $ const True
|
||||
|
||||
_IndicatorMap :: Iso' (Set k) (Map k Bool)
|
||||
_IndicatorMap = iso mapFromSet setFromMap
|
||||
|
||||
----------
|
||||
-- Maps --
|
||||
----------
|
||||
|
||||
@ -11,6 +11,7 @@ module Utils.DateTime
|
||||
, mkDateTimeFormatter
|
||||
, nominalHour, nominalMinute
|
||||
, minNominalYear, avgNominalYear
|
||||
, nominalTimeToTimeOfDay, timeOfDayToNominalTime
|
||||
, module Zones
|
||||
, day
|
||||
) where
|
||||
@ -24,6 +25,7 @@ import Data.Time.Zones.TH as Zones (includeSystemTZ)
|
||||
import Data.Time.Zones (localTimeToUTCTZ, timeZoneForUTCTime)
|
||||
import Data.Time.Format (FormatTime)
|
||||
import Data.Time.Clock.System (systemEpochDay)
|
||||
import Data.Time.LocalTime (timeToTimeOfDay, timeOfDayToTime)
|
||||
import qualified Data.Time.Format.ISO8601 as Time
|
||||
import qualified Data.Time.Format as Time
|
||||
|
||||
@ -148,6 +150,11 @@ minNominalYear, avgNominalYear :: NominalDiffTime
|
||||
minNominalYear = 365 * nominalDay
|
||||
avgNominalYear = fromRational $ 365.2425 * toRational nominalDay
|
||||
|
||||
nominalTimeToTimeOfDay :: NominalDiffTime -> TimeOfDay
|
||||
nominalTimeToTimeOfDay = timeToTimeOfDay . realToFrac
|
||||
timeOfDayToNominalTime :: TimeOfDay -> NominalDiffTime
|
||||
timeOfDayToNominalTime = realToFrac . timeOfDayToTime
|
||||
|
||||
---------
|
||||
-- Day --
|
||||
---------
|
||||
|
||||
@ -664,6 +664,28 @@ daysField = convertField fromDays toDays fractionalField
|
||||
toDays = (/ nominalDay)
|
||||
fromDays = (* nominalDay)
|
||||
|
||||
timeOfDayField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m NominalDiffTime
|
||||
timeOfDayField = Field{..}
|
||||
where
|
||||
precision :: Pico
|
||||
precision = MkFixed 1
|
||||
timeFormat :: String
|
||||
timeFormat = "%H:%M:%S%Q"
|
||||
|
||||
fieldEnctype = UrlEncoded
|
||||
fieldView theId name attrs val' isReq
|
||||
= [whamlet|
|
||||
$newline never
|
||||
<input id=#{theId} name=#{name} *{attrs} type=time step=#{showFixed True precision} :isReq:required value=#{val}>
|
||||
|]
|
||||
where val :: Text
|
||||
val = either id (pack . formatTime defaultTimeLocale timeFormat . nominalTimeToTimeOfDay) val'
|
||||
fieldParse = parseHelper $ \t
|
||||
-> case parseTimeM True defaultTimeLocale timeFormat (T.unpack t) of
|
||||
Just tod -> Right $ timeOfDayToNominalTime tod
|
||||
Nothing -> Left MsgInvalidTimeFormat
|
||||
|
||||
|
||||
|
||||
data SecretJSONFieldException = SecretJSONFieldDecryptFailure
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
@ -1081,7 +1103,7 @@ hoistField f Field{..} = Field
|
||||
}
|
||||
|
||||
prismAForm :: Monad m => Prism' s a -> Maybe s -> (Maybe a -> AForm m a) -> AForm m s
|
||||
-- ^ @Monad m => Prism' s a -> (Maybe a -> AForm m a) -> (Maybe s -> AForm m s)@
|
||||
-- ^ TODO: @Monad m => Prism' s a -> (Maybe a -> AForm m a) -> (Maybe s -> AForm m s)@
|
||||
prismAForm p outer form = review p <$> form inner
|
||||
where
|
||||
inner = outer >>= preview p
|
||||
|
||||
@ -4,6 +4,8 @@ module Utils.Schedule.Types.ScheduleView
|
||||
|
||||
import Import.NoModel
|
||||
|
||||
import Model.Types.TH.PathPiece
|
||||
|
||||
|
||||
data ScheduleView = ScheduleViewWeek
|
||||
deriving (Eq, Ord, Enum, Show, Read, Generic, Typeable)
|
||||
@ -14,4 +16,7 @@ instance Bounded ScheduleView where
|
||||
instance Finite ScheduleView
|
||||
instance Universe ScheduleView
|
||||
|
||||
derivePathPiece ''ScheduleView (camelToPathPiece' 1) "_"
|
||||
nullaryPathPiece ''ScheduleView $ camelToPathPiece' 2
|
||||
pathPieceJSON ''ScheduleView
|
||||
pathPieceJSONKey ''ScheduleView
|
||||
derivePersistFieldPathPiece ''ScheduleView
|
||||
|
||||
@ -21,7 +21,6 @@ import Utils.Schedule.Week.TimeSlot
|
||||
weekSchedule :: Entity User -> ScheduleOffset -> Widget
|
||||
weekSchedule (Entity uid User{userScheduleWeekDays=ScheduleWeekDays userScheduleWeekDays,..}) scheduleOffset = do
|
||||
now <- liftIO getCurrentTime
|
||||
tz <- liftIO getCurrentTimeZone
|
||||
ata <- getSessionActiveAuthTags
|
||||
|
||||
let
|
||||
@ -86,7 +85,7 @@ weekSchedule (Entity uid User{userScheduleWeekDays=ScheduleWeekDays userSchedule
|
||||
( d
|
||||
, Map.fromList $ allTimeSlots <&> \slot ->
|
||||
( slot
|
||||
, filter (seIsInSlot tz d slot) scheduleEntries
|
||||
, filter (seIsInSlot d slot) scheduleEntries
|
||||
)
|
||||
) where
|
||||
scheduleEntries = join $ (courseEventToScheduleEntries <$> courseEvents)
|
||||
@ -129,7 +128,7 @@ weekSchedule (Entity uid User{userScheduleWeekDays=ScheduleWeekDays userSchedule
|
||||
timeSlotsDefaultDisplay = Set.fromList $ timeSlotsFromTo userScheduleWeekTimeslotLength userScheduleWeekTimeFrom userScheduleWeekTimeTo
|
||||
|
||||
allTimeSlots :: [TimeSlot]
|
||||
allTimeSlots = timeSlotsFromTo userScheduleWeekTimeslotLength 0 (24 - userScheduleWeekTimeslotLength)
|
||||
allTimeSlots = timeSlotsAll userScheduleWeekTimeslotLength userScheduleWeekTimeFrom
|
||||
|
||||
timeSlotIsEmpty :: TimeSlot -> Bool
|
||||
timeSlotIsEmpty slot = foldr (\d acc -> acc && maybe True null (d Map.!? slot)) True events
|
||||
@ -140,8 +139,8 @@ weekSchedule (Entity uid User{userScheduleWeekDays=ScheduleWeekDays userSchedule
|
||||
-- Local helper functions
|
||||
|
||||
-- | Check whether a given ScheduleEntry lies in a given TimeSlot
|
||||
seIsInSlot :: TimeZone -> Day -> TimeSlot -> ScheduleEntry -> Bool
|
||||
seIsInSlot tz d slot =
|
||||
seIsInSlot :: Day -> TimeSlot -> ScheduleEntry -> Bool
|
||||
seIsInSlot d slot =
|
||||
let occurrenceIsInSlot occurrence = occDay == d && occTime `isInTimeSlot` slot where
|
||||
(occDay, occTime) = case occurrence of
|
||||
Right ScheduleWeekly{..} -> (scheduleDayOfWeek `dayOfWeekToDayWith` d, scheduleStart)
|
||||
@ -150,7 +149,7 @@ seIsInSlot tz d slot =
|
||||
in \case
|
||||
ScheduleCourseEvent{sceOccurrence} -> occurrenceIsInSlot sceOccurrence
|
||||
ScheduleTutorial{stOccurrence} -> occurrenceIsInSlot stOccurrence
|
||||
ScheduleExamOccurrence{seoStart} -> let (slotTime,nextSlotTime) = timeSlotToUTCTime tz d slot
|
||||
ScheduleExamOccurrence{seoStart} -> let (slotTime,nextSlotTime) = timeSlotToUTCTime d slot
|
||||
in slotTime <= seoStart
|
||||
&& seoStart < nextSlotTime
|
||||
|
||||
|
||||
@ -1,7 +1,6 @@
|
||||
module Utils.Schedule.Week.TimeSlot
|
||||
( TimeSlot(..)
|
||||
, timeSlot
|
||||
, timeSlotsFromTo
|
||||
, timeSlots, timeSlotsFromTo, timeSlotsAll
|
||||
, isInTimeSlot
|
||||
, nextTimeSlot
|
||||
, timeSlotToUTCTime
|
||||
@ -10,7 +9,7 @@ module Utils.Schedule.Week.TimeSlot
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils.DateTime (formatTimeRangeW)
|
||||
import Handler.Utils.DateTime (formatTimeRangeW, localTimeToUTCSimple)
|
||||
|
||||
import Utils.Schedule.Week.Types.TimeSlot
|
||||
|
||||
@ -18,38 +17,51 @@ import Utils.Schedule.Week.Types.TimeSlot
|
||||
-- TODO: This module needs major refactoring
|
||||
|
||||
|
||||
-- TODO: remove (deprecated; now in user settings)
|
||||
-- slotStep :: Int
|
||||
-- slotStep = 2
|
||||
timeSlots :: Bool -- ^ Only slots between from/to?
|
||||
-> NominalDiffTime -- ^ Step
|
||||
-> NominalDiffTime -- ^ From
|
||||
-> NominalDiffTime -- ^ To
|
||||
-> [TimeSlot]
|
||||
timeSlots onlyFromTo (abs -> slotStep) f t
|
||||
| t < f = timeSlots onlyFromTo slotStep t f
|
||||
| slotStep <= 0 = error "Invalid slotStep"
|
||||
| otherwise = reverse [ TimeSlot{..}
|
||||
| tsTo <- [f,f - slotStep..0]
|
||||
, let tsFrom = tsTo - slotStep
|
||||
, not onlyFromTo || tsFrom >= f
|
||||
, tsFrom >= 0
|
||||
]
|
||||
++ [ TimeSlot{..}
|
||||
| tsFrom <- [f,f + slotStep..nominalDay]
|
||||
, let tsTo = tsFrom + slotStep
|
||||
, not onlyFromTo || tsTo <= t
|
||||
, tsTo <= nominalDay
|
||||
]
|
||||
|
||||
timeSlotsFromTo :: NominalDiffTime -- ^ Step
|
||||
-> NominalDiffTime -- ^ From
|
||||
-> NominalDiffTime -- ^ To
|
||||
-> [TimeSlot]
|
||||
timeSlotsFromTo = timeSlots True
|
||||
|
||||
timeSlot :: Int -> Int -> TimeSlot
|
||||
timeSlot slotStep h = TimeSlot{..} where
|
||||
tsFrom = TimeOfDay h 0 0
|
||||
tsTo = TimeOfDay (h+slotStep) 0 0
|
||||
|
||||
|
||||
-- | Get TimeSlots from a given start TimeOfDay to a given end TimeOfDay
|
||||
timeSlotsFromTo :: Int -> Int -> Int -> [TimeSlot]
|
||||
timeSlotsFromTo slotStep f t = (timeSlot slotStep) <$> [f,f+slotStep..t]
|
||||
timeSlotsAll :: NominalDiffTime -- ^ Step
|
||||
-> NominalDiffTime -- ^ From
|
||||
-> [TimeSlot]
|
||||
timeSlotsAll step f = timeSlots False step f f -- @t@ is unused in `timeSlots`, iff @onlyFromTo@ is `False`
|
||||
|
||||
-- | Check whether a given time of day lies within a given TimeSlot
|
||||
isInTimeSlot :: TimeOfDay -> TimeSlot -> Bool
|
||||
isInTimeSlot time TimeSlot{..} = tsFrom <= time && time < tsTo
|
||||
isInTimeSlot (timeOfDayToNominalTime -> time) TimeSlot{..} = tsFrom <= time && time < tsTo
|
||||
|
||||
-- | Get the successor of a TimeSlot
|
||||
nextTimeSlot :: Int -> TimeSlot -> TimeSlot
|
||||
nextTimeSlot slotStep TimeSlot{tsTo=tsFrom} = let tsTo = TimeOfDay (todHour tsFrom + slotStep) 0 0 in TimeSlot{..}
|
||||
nextTimeSlot :: NominalDiffTime -> TimeSlot -> TimeSlot
|
||||
nextTimeSlot slotStep TimeSlot{..} = TimeSlot{ tsFrom = tsTo, tsTo = tsTo + slotStep }
|
||||
|
||||
-- | Convert a TimeSlot to UTCTime for a given TimeZone
|
||||
timeSlotToUTCTime :: TimeZone -> Day -> TimeSlot -> (UTCTime, UTCTime)
|
||||
timeSlotToUTCTime tz d TimeSlot{..} = (timeOfDayToUTC tsFrom, timeOfDayToUTC tsTo) where
|
||||
timeOfDayToUTC time =
|
||||
let (slotDayOffset, slotTimeOfDay) = localToUTCTimeOfDay tz time
|
||||
utctDay = slotDayOffset `addDays` d
|
||||
utctDayTime = timeOfDayToTime slotTimeOfDay
|
||||
in UTCTime{..}
|
||||
timeSlotToUTCTime :: Day -> TimeSlot -> (UTCTime, UTCTime)
|
||||
timeSlotToUTCTime d TimeSlot{..} = (timeOfDayToUTC tsFrom, timeOfDayToUTC tsTo)
|
||||
where timeOfDayToUTC = localTimeToUTCSimple . LocalTime d . nominalTimeToTimeOfDay
|
||||
|
||||
-- | Format a given TimeSlot as time range
|
||||
formatTimeSlotW :: TimeSlot -> Widget
|
||||
formatTimeSlotW TimeSlot{..} = formatTimeRangeW SelFormatTime tsFrom $ Just tsTo
|
||||
formatTimeSlotW TimeSlot{..} = formatTimeRangeW SelFormatTime (nominalTimeToTimeOfDay tsFrom) $ Just (nominalTimeToTimeOfDay tsTo)
|
||||
|
||||
@ -5,8 +5,10 @@ module Utils.Schedule.Week.Types.TimeSlot
|
||||
import Import.NoModel
|
||||
|
||||
|
||||
-- | Half-open interval of time
|
||||
--
|
||||
-- Fields are to be interpreted as time since midnight
|
||||
data TimeSlot = TimeSlot
|
||||
{ tsFrom :: TimeOfDay
|
||||
, tsTo :: TimeOfDay -- end excluded
|
||||
}
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
{ tsFrom :: NominalDiffTime -- ^ Inclusive
|
||||
, tsTo :: NominalDiffTime -- ^ Exclusive
|
||||
} deriving (Eq, Ord, Show, Generic, Typeable)
|
||||
|
||||
@ -2,8 +2,9 @@ $newline never
|
||||
|
||||
#{csrf}
|
||||
|
||||
$forall vWgt <- viewWidgets
|
||||
^{fvWidget vWgt}
|
||||
$if length viewWidgets > 1
|
||||
$forall vWgt <- viewWidgets
|
||||
^{fvWidget vWgt}
|
||||
|
||||
$forall oWgt <- offsetWidgets
|
||||
^{fvWidget oWgt}
|
||||
|
||||
@ -13,7 +13,7 @@ $newline never
|
||||
$forall slot <- allTimeSlots
|
||||
$if Set.member slot timeSlotsDefaultDisplay || not (timeSlotIsEmpty slot)
|
||||
<tr .table__row>
|
||||
<td .table__td>
|
||||
<th .table__th uw-hide-columns--no-hide>
|
||||
^{formatTimeSlotW slot}
|
||||
$forall day <- week
|
||||
$maybe dayEvents <- Map.lookup day events
|
||||
|
||||
Reference in New Issue
Block a user