chore(daily): add page actions #90

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

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

src/Foundation/Navigation.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- 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
 

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 "course")    (i18nCell MsgFilterCourse)     $ \(view $ resultCourse . _entityVal -> c) -> courseCell c
-      , sortable (Just "tutorial")  (i18nCell MsgCourseTutorial)   $ \(view $ resultTutorial . _entityVal . _tutorialName . _CI -> t) -> textCell t
+      , 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))

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)

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]