From 4dbe005709743c683cf78cc629b651f1c2552812 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 13 Sep 2024 16:18:38 +0200 Subject: [PATCH] chore(daily): add page actions #90 --- .../utils/handler_form/occurrences/de-de-formal.msg | 4 ++++ .../uniworx/utils/handler_form/occurrences/en-eu.msg | 4 ++++ src/Foundation/Navigation.hs | 11 +++++++++-- src/Handler/School/DayTasks.hs | 11 ++++++++--- src/Import/NoModel.hs | 7 +++++++ src/Model/Types/DateTime.hs | 6 ------ 6 files changed, 32 insertions(+), 11 deletions(-) diff --git a/messages/uniworx/utils/handler_form/occurrences/de-de-formal.msg b/messages/uniworx/utils/handler_form/occurrences/de-de-formal.msg index e70c0a30d..24119b496 100644 --- a/messages/uniworx/utils/handler_form/occurrences/de-de-formal.msg +++ b/messages/uniworx/utils/handler_form/occurrences/de-de-formal.msg @@ -20,3 +20,7 @@ ExceptionNoOccurAt: Termin ExceptionKind: Termin ... ExceptionKindOccur: Findet statt ExceptionKindNoOccur: Findet nicht statt +DayNext: Folgetag +DayPrev: Vortag +WeekNext: Nächste Woche +WeekPrev: Vorherige Woche diff --git a/messages/uniworx/utils/handler_form/occurrences/en-eu.msg b/messages/uniworx/utils/handler_form/occurrences/en-eu.msg index 1c325ea7f..62f629add 100644 --- a/messages/uniworx/utils/handler_form/occurrences/en-eu.msg +++ b/messages/uniworx/utils/handler_form/occurrences/en-eu.msg @@ -20,3 +20,7 @@ ExceptionNoOccurAt: Event ExceptionKind: Event ... ExceptionKindOccur: Does occur ExceptionKindNoOccur: Does not occur +DayNext: Next day +DayPrev: Previous day +WeekNext: Next week +WeekPrev: Previous week \ No newline at end of file diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 0bf6d5306..bcd9f152a 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -1201,6 +1201,13 @@ pageActions SchoolListR = return , navChildren = [] } ] +pageActions (SchoolR ssh (SchoolDayR nd)) = return + [ NavPageActionPrimary + { navLink = defNavLink msg $ SchoolR ssh (SchoolDayR $ addDays n nd) + , navChildren = [] + } + | (msg, n) <- [(MsgWeekPrev, -7), (MsgDayPrev, -1), (MsgDayNext, 1), (MsgWeekNext, 7)] + ] pageActions UsersR = return [ NavPageActionPrimary { navLink = NavLink @@ -2583,7 +2590,7 @@ submissionList tid csh shn uid = withReaderT (projectBackend @SqlReadBackend) . E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid - E.&&. sheet E.^. SheetName E.==. E.val shn + E.&&. sheet E.^. SheetName E.==. E.val shn E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseTerm E.==. E.val tid diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 846e1b615..29219e84a 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -82,17 +82,22 @@ mkDailyTable ssh nd = do EL.on $ course E.^. CourseId E.==. tut E.^. TutorialCourse E.where_ $ course E.^. CourseSchool E.==. E.val ssh E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue nd)) - E.&&. E.exists $ do + E.&&. E.exists (do trm <- E.from $ E.table @Term E.where_ $ E.between (E.val nd) (trm E.^. TermStart, trm E.^. TermEnd) E.&&. trm E.^. TermId E.==. course E.^. CourseTerm + ) return (course, tut) dbtRowKey = queryTutorial >>> (E.^. TutorialId) dbtProj = dbtProjId dbtColonnade = mconcat [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey)) - sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal . _courseName . _CI -> t) -> textCell t - , sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \(view $ resultTutorial . _entityVal . _tutorialName . _CI -> t) -> textCell t + sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c + , sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \row -> + let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh} + = row ^. resultCourse . _entityVal + tutName = row ^. resultTutorial . _entityVal . _tutorialName + in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName ] dbtSorting = Map.fromList [ ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index ac2fb34f5..adbc5df67 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -2,6 +2,8 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Import.NoModel ( module Import , MForm @@ -270,3 +272,8 @@ import Control.Monad.Trans.RWS (RWST) type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m type WeekDay = DayOfWeek + +-- TODO: maybe move elsewhere +deriving newtype instance NFData a => NFData (JSONB a) +deriving newtype instance Semigroup a => Semigroup (JSONB a) +deriving newtype instance Monoid a => Monoid (JSONB a) diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index b329ad68e..43c24a761 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -233,11 +233,6 @@ instance Semigroup Occurrences where instance Monoid Occurrences where mempty = Occurrences mempty mempty --- TODO: move elsewhere -deriving newtype instance NFData a => NFData (JSONB a) -deriving newtype instance Semigroup a => Semigroup (JSONB a) -deriving newtype instance Monoid a => Monoid (JSONB a) - jsonbOCCUR :: Maybe (JSONB Occurrences) -> Occurrences jsonbOCCUR = foldMap unJSONB @@ -248,7 +243,6 @@ _Occurrences :: Iso' (JSONB Occurrences) Occurrences _Occurrences = iso unJSONB JSONB - nullaryPathPiece ''DayOfWeek camelToPathPiece -- test :: IO [OccurrenceException]