chore(daily): add suggestions to note fiels (WIP)

messages/uniworx/categories/courses/tutorial/de-de-formal.msg

@@ -56,4 +56,4 @@ TutorialEyeExam: Sehtest
 TutorialNote: Kursnotiz
 TutorialDayAttendance day@Text: Anwesenheit #{day}
 TutorialDayNote day@Text: Anwesenheitsnotiz für #{day}
-TutorialParticipantsDayEdits n@Int: #{tshow n} Kursteilnehmer-Tagesnotizen aktualisiert
+TutorialParticipantsDayEdits day@Text: Kursteilnehmer-Tagesnotizen aktualisiert für #{day}

messages/uniworx/categories/courses/tutorial/en-eu.msg

@@ -57,4 +57,4 @@ TutorialEyeExam: Eye exam
 TutorialNote: Course note
 TutorialDayAttendance day: Attendance #{day}
 TutorialDayNote day: Attendance note #{day}
-TutorialParticipantsDayEdits n@Int: #{tshow n} course participant day notes updated
+TutorialParticipantsDayEdits day: course participant day notes updated for #{day}

src/Handler/School/DayTasks.hs

@@ -33,6 +33,9 @@ import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.))
 import Database.Esqueleto.Utils.TH
 
 
+-- | Maximal number of suggestions for note fields in Day Task view
+maxSuggestions :: Int64
+maxSuggestions = 7
 
 -- data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing
 --   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
@@ -246,7 +249,8 @@ eyeExamField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, Hand
 eyeExamField = selectField' (Just $ SomeMessage MsgBoolIrrelevant) optionsFinite
 
 mkDailyFormColumn :: (RenderMessage UniWorX msg) => Text -> msg -> Lens' DailyTableData a -> ASetter' DailyFormData a -> Field _ a -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
-mkDailyFormColumn k msg lg ls f = sortable (Just $ SortingKey $ stripCI k) (i18nCell msg) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
+mkDailyFormColumn k msg lg ls f = sortable (Just $ SortingKey $ stripCI k) (i18nCell msg) $ formCell
+  id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
   (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
   (\(view lg -> x) mkUnique ->
     over (_1.mapped) (ls .~) . over _2 fvWidget <$> mreq f (fsUniq mkUnique k) (Just x)
@@ -256,7 +260,8 @@ colParticipantPermitField :: Colonnade Sortable DailyTableData (DBCell _ (FormRe
 colParticipantPermitField = colParticipantPermitField' _dailyFormDrivingPermit
 
 colParticipantPermitField' :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
-colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ (cellAttrs <>~ [("style","width:1%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
+colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ (cellAttrs <>~ [("style","width:1%")]) <$> formCell
+  id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
   (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
   (\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique ->
     over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit") (Just x)
@@ -283,11 +288,53 @@ colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorial
 colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
 colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id
   (views (resultParticipant . _entityKey) return)
-  (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique ->
-    over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap Text.strip) . over _2 fvWidget <$>
-      mopt textField (fsUniq mkUnique "note-tutorial") (Just note)
+  (\row mkUnique ->
+    let note = row ^. resultParticipant . _entityVal . _tutorialParticipantNote
+        cid  = row ^. resultCourse . _entityKey
+        tid  = row ^. resultTutorial . _entityKey
+    in over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap Text.strip) . over _2 fvWidget <$>
+      mopt (textField & cfStrip & addDatalist (suggsParticipantNote cid tid)) (fsUniq mkUnique "note-tutorial") (Just note)
   )
 
+suggsParticipantNote :: CourseId -> TutorialId -> Handler (OptionList Text)
+suggsParticipantNote cid tid = memcachedByHere (Just . Right $ 12 * diffSecond) (cid,tid) $ do -- TODO: better memcached key
+  let qry = do
+        (prio, tpn) <- E.from $ TutorialParticipant
+          ( do
+              tpa <- E.from $ E.table @TutorialParticipant
+              E.distinct $ pure ()
+              E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
+                  E.&&.  tpa E.^. TutorialParticipantTutorial E.==. E.val tid
+              E.limit maxSuggestions
+              pure (E.val 1, tpa E.^. TutorialParticipantNote)
+          ) `E.unionAll_`
+          ( do
+              (tpa :& tut) <- E.from $  E.table @TutorialParticipant
+                          `E.innerJoin` E.table @Tutorial
+                          `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial)
+              E.distinct $ pure ()
+              E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
+                  E.&&.   tut E.^. TutorialCourse E.==. E.val cid
+              E.orderBy [E.desc $ tut E.^. TutorialLastChanged]
+              E.limit maxSuggestions
+              pure (E.val 2, tpa E.^. TutorialParticipantNote)
+          ) `E.unionAll_`
+          ( do
+              tpa <- E.from $ E.table @TutorialParticipant
+              E.distinct $ pure ()
+              E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
+              E.limit maxSuggestions
+              pure (E.val 3, tpa E.^. TutorialParticipantNote)
+          )
+        E.orderBy [E.asc prio, E.asc tpn]
+        E.limit maxSuggestions
+        pure tpn
+  mkOptionsE qry E.unValue (text2message . E.unValue) (toPathPiece . E.unValue)
+
+
+suggsAttentionNote :: Handler (OptionList Textarea)
+suggsAttentionNote = error "TODO"
+
 colAttendanceField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
 colAttendanceField dday = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ formCell id
   (views (resultParticipant . _entityKey) return)
@@ -310,8 +357,16 @@ colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutor
 colParkingField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
 colParkingField = colParkingField' _dailyFormParkingToken
 
+-- colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
+-- colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id
+--   (views (resultParticipant . _entityKey) return)
+--   (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique ->
+--     over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking
+--   )
+
 colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
-colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id
+colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell
+  id -- TODO: this should not be id! Refactor to simplify the thrid argument below
   (views (resultParticipant . _entityKey) return)
   (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique ->
     over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking
@@ -368,16 +423,30 @@ mkDailyTable isAdmin ssh nd = do
                 , Just (unCompanyKey -> csh) <- primComp
                   = bookLink
                   <> spacerCell
-                  <> cell (modal (toWidget iconCompanyWarning) (Right -- TODO: use iconCompanyWarning instead!
-                      [whamlet|
-                        <h2>
-                          ^{userWidget row}
-                        <p>
-                          _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}
-                      |]
-                      ))
-                | otherwise = bookLink <> iconCell IconCertificate
+                  <> cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|]
+                          (Just IconCompanyWarning) True)
+                | otherwise = bookLink
           in result
+      -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row ->
+      --     let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany
+      --         primComp = row ^? resultCompanyId
+      --         bookLink = cellMaybe companyIdCell bookComp
+      --         warnIcon = \csh -> iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] (Just IconCompanyWarning) True
+      --         result
+      --           | primComp /= bookComp
+      --           , Just (unCompanyKey -> csh) <- primComp
+      --             = bookLink
+      --             <> spacerCell
+      --             <> cell (modal (warnIcon csh) (Right -- TODO: use iconCompanyWarning instead!
+      --                 [whamlet|
+      --                   <h2>
+      --                     ^{userWidget row}
+      --                   <p>
+      --                     _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}
+      --                 |]
+      --                 ))
+      --           | otherwise = bookLink
+      --     in result
       , colUserNameModalHdr MsgCourseParticipant ForProfileDataR
       , colUserMatriclenr isAdmin
       , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn
@@ -505,8 +574,8 @@ postSchoolDayR ssh nd = do
                               then flip upsertBy_ (UserDay tutorialParticipantUser nd dailyFormParkingToken) -- upsert if a permit was issued
                               else      updateBy  -- only update to no permit, if the record exists, but do not create a fresh record with parkingToken==False
         updateUserDay udUq [ UserDayParkingToken =. dailyFormParkingToken]
-    -- TODO: audit log?
-    addMessageI Success $ MsgTutorialParticipantsDayEdits $ Map.size resMap
+    -- audit log? Currently decided against.
+    addMessageI Success $ MsgTutorialParticipantsDayEdits dday
     redirect $ SchoolR ssh $ SchoolDayR nd
 
   siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do

src/Handler/Utils/Form.hs

@@ -1604,7 +1604,7 @@ mkOptionsE :: forall a r b msg.
            -> YesodDB UniWorX (OptionList b)
 mkOptionsE query toExternal toDisplay toInternal = do
   mr <- getMessageRender
-  let toOption x = Option <$> (mr <$> toDisplay x) <*> toInternal x <*> toExternal x
+  let toOption x = (Option . mr <$> toDisplay x) <*> toInternal x <*> toExternal x
   fmap (mkOptionList . toList) . runConduit $
     E.selectSource query .| C.mapM toOption .| C.foldMap Seq.singleton