chore(daily): adjust css, improve suggestions

frontend/src/utils/inputs/inputs.sass

@@ -163,7 +163,6 @@ input[type*='time'],
 // TEXTAREAS
 textarea
   width: 100%
-  height: 170px
   max-width: 600px
   line-height: 1.5
   color: #363636
@@ -176,6 +175,8 @@ textarea
   border-radius: 2px
   box-shadow: inset 0 1px 2px 1px rgba(50, 50, 50, 0.05)
   vertical-align: top
+  &:not(.uwx-short)
+    height: 172px
 
 // SHARED STATE RELATED STYLES
 
@@ -211,10 +212,11 @@ option
   border-radius: 2px
   outline: 0
   color: #363636
-  min-width: 250px
   width: auto
   background-color: #f3f3f3
   box-shadow: inset 0 1px 2px 1px rgba(50, 50, 50, 0.05)
+  &:not(.uwx-narrow)
+    min-width: 250px
 
 @media (max-width: 425px)
   select, option

src/Handler/Admin/Avs.hs

@@ -734,11 +734,9 @@ mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do
           E.orderBy [E.desc countRows']
           E.limit 7
           pure (qblock E.^. QualificationUserBlockReason)
-      mkOption :: E.Value Text -> Option Text
-      mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
       suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
-      suggestionsBlock   = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons E.not__)
-      suggestionsUnblock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons id)
+      suggestionsBlock   = mkOptionListText <$> runDBRead (getBlockReasons E.not__)
+      suggestionsUnblock = mkOptionListText <$> runDBRead (getBlockReasons id)
 
       acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
       acts = mconcat

src/Handler/Health/Interface.hs

@@ -308,17 +308,15 @@ wildcardCell c (Just x) = c x
 mkInterfaceWarnTable :: DB (FormResult (IWTableActionData, Set InterfaceHealthId), Widget)
 mkInterfaceWarnTable = do
   let
-    mkOption :: E.Value Text -> Option Text
-    mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
     getSuggestion pj = E.select $ E.distinct $ do
       il <- E.from $ E.table @InterfaceLog
       let res = il E.^. pj
       E.orderBy [E.asc res]
       pure res
     suggestionInterface :: HandlerFor UniWorX (OptionList Text)
-    suggestionInterface = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogInterface)
+    suggestionInterface = mkOptionList . fmap mkOptionText <$> runDB (getSuggestion InterfaceLogInterface)
     suggestionSubtype   :: HandlerFor UniWorX (OptionList Text)
-    suggestionSubtype   = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogSubtype)
+    suggestionSubtype   = mkOptionList . fmap mkOptionText <$> runDB (getSuggestion InterfaceLogSubtype)
     dbtIdent = "interface-warnings" :: Text
     dbtSQLQuery :: IWTableExpr -> E.SqlQuery IWTableExpr
     dbtSQLQuery = return

src/Handler/Qualification.hs

@@ -538,11 +538,9 @@ postQualificationR sid qsh = do
           Ex.orderBy [Ex.desc countRows']
           Ex.limit 9
           pure (qblock Ex.^. QualificationUserBlockReason)
-        mkOption :: Ex.Value Text -> Option Text
-        mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
         suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
-        suggestionsBlock   = mkOptionList . fmap mkOption <$> runDB (getBlockReasons Ex.not_)
-        suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
+        suggestionsBlock   = mkOptionListText <$> runDB (getBlockReasons Ex.not_)
+        suggestionsUnblock = mkOptionListText <$> runDB (getBlockReasons id)
         dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths
         acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
         acts = mconcat $

src/Handler/School/DayTasks.hs

@@ -264,17 +264,17 @@ colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialDri
   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)
+    over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit" & addClass' "uwx-narrow") (Just x)
   )   -- Given the row data and a callback to make an input name suitably unique generate the MForm
 
 colParticipantEyeExamField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
 colParticipantEyeExamField = colParticipantEyeExamField' _dailyFormEyeExam
 
 colParticipantEyeExamField' :: ASetter' a (Maybe UserEyeExam) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
-colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ (cellAttrs <>~ [("style","width:2%")]) <$> formCell id
+colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ (cellAttrs <>~ [("style","width:1%")]) <$> formCell id
   (views (resultParticipant . _entityKey) return)
   (\(view (resultParticipant . _entityVal . _tutorialParticipantEyeExam) -> x) mkUnique ->
-    over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt eyeExamField (fsUniq mkUnique "eye-exam") (Just x)
+    over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt eyeExamField (fsUniq mkUnique "eye-exam" & addClass' "uwx-narrow") (Just x)
   )
 
 -- colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
@@ -290,74 +290,138 @@ colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialN
   (views (resultParticipant . _entityKey) return)
   (\row mkUnique ->
     let note = row ^. resultParticipant . _entityVal . _tutorialParticipantNote
+        sid  = row ^. resultCourse . _entityVal . _courseSchool
         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)
+      mopt (textField & cfStrip & addDatalist (suggsParticipantNote sid cid tid)) (fsUniq mkUnique "note-tutorial") (Just note)
   )
 
--- deriving instance (Generic a) => Generic (OptionList a)
--- deriving instance (Binary a, Generic a) => Binary (OptionList a)
--- deriving instance Generic (OptionList Text)
--- deriving instance Binary  (OptionList Text)
-deriving instance Generic (Option Text)
-deriving instance Binary (Option Text)
-
-suggsParticipantNote :: CourseId -> TutorialId -> Handler (OptionList Text)
-suggsParticipantNote cid tid = $(memcachedByHere) (Just . Right $ 12 * diffSecond) (cid,tid) $ runDB $ do -- TODO: better memcached key
-  let qry :: E.SqlQuery (E.SqlExpr (E.Value Text)) = do
-        (prio, tpn) <- E.from $
+suggsParticipantNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text)
+suggsParticipantNote sid cid tid = do
+  ol <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough?
+    suggs <- runDB $ E.select $ do
+      let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
+      (tpn, prio) <- E.from $
         ( 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.groupBy $ tpa E.^. TutorialParticipantNote
+            E.orderBy [E.desc countRows']
             E.limit maxSuggestions
-              pure (E.val (1 :: Int64), tpa E.^. TutorialParticipantNote)
+            pure (tpa E.^. TutorialParticipantNote, E.val (1 :: Int64))
         ) `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.&&. tpa E.^. TutorialParticipantTutorial E.!=. E.val tid
                 E.&&. tut E.^. TutorialCourse E.==. E.val cid
-              E.orderBy [E.desc $ tut E.^. TutorialLastChanged]
+            E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantNote)
+            E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows']
             E.limit maxSuggestions
-              pure (E.val 2, tpa E.^. TutorialParticipantNote)
+            pure (tpa E.^. TutorialParticipantNote, E.val 2)
         ) `E.unionAll_`
         ( do
-              tpa <- E.from $ E.table @TutorialParticipant
-              E.distinct $ pure ()
+            tpa :& tut :& crs <- E.from $ E.table @TutorialParticipant
+                        `E.innerJoin` E.table @Tutorial
+                        `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial)
+                        `E.innerJoin` E.table @Course
+                        `E.on` (\(_ :& tut :& crs) -> tut E.^. TutorialCourse E.==. crs E.^. CourseId)
             E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
+                E.&&. tpa E.^. TutorialParticipantTutorial E.!=. E.val tid
+                E.&&. tut E.^. TutorialCourse E.!=. E.val cid
+                E.&&. crs E.^. CourseSchool E.==. E.val sid
+            E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantNote)
+            E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows']
             E.limit maxSuggestions
-              pure (E.val 3, tpa E.^. TutorialParticipantNote)
+            pure (tpa E.^. TutorialParticipantNote, E.val 3)
         )
+      E.groupBy (tpn, prio)
       E.orderBy [E.asc prio, E.asc tpn]
       E.limit maxSuggestions
-        pure $ E.coalesceDefault [tpn] $ E.val ""
-  mkOptionsE qry (pure . E.unValue) (pure . text2message . E.unValue) (pure . toPathPiece . E.unValue)
+      pure $ E.coalesceDefault [tpn] $ E.val "" -- default never used due to where_ condtions, but conveniently changes type
+    --    $logInfoS "NOTE-SUGGS *** A: " $ tshow suggs
+    pure $ mkOptionListCacheable $ mkOptionText <$> nubOrd suggs
+  --      $logInfoS "NOTE-SUGGS *** B: " $ tshow ol
+  pure $ mkOptionListFromCacheable ol
 
+suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Textarea)
+suggsAttendanceNote sid cid tid = do
+  ol <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough?
+    suggs <- runDB $ E.select $ do
+      let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
+      (tpn, prio) <- E.from $
+        ( do
+            tpa <- E.from $ E.table @TutorialParticipantDay
+            E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote)
+                E.&&.  tpa E.^. TutorialParticipantDayTutorial E.==. E.val tid
+            E.groupBy (tpa E.^. TutorialParticipantDayNote, tpa E.^. TutorialParticipantDayDay)
+            E.orderBy [E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc countRows']
+            E.limit maxSuggestions
+            pure (tpa E.^. TutorialParticipantDayNote, E.val (1 :: Int64))
+        -- ) `E.unionAll_`
+        -- ( do
+        --     (tpa :& tut) <- E.from $  E.table @TutorialParticipantDay
+        --                 `E.innerJoin` E.table @Tutorial
+        --                 `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial)
+        --     E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote)
+        --         E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid
+        --         E.&&. tut E.^. TutorialCourse E.==. E.val cid
+        --     E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantDayNote)
+        --     E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc countRows']
+        --     E.limit maxSuggestions
+        --     pure (tpa E.^. TutorialParticipantDayNote, E.val 2)
+        -- ) `E.unionAll_`
+        -- ( do
+        --     tpa :& tut :& crs <- E.from $ E.table @TutorialParticipantDay
+        --                 `E.innerJoin` E.table @Tutorial
+        --                 `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial)
+        --                 `E.innerJoin` E.table @Course
+        --                 `E.on` (\(_ :& tut :& crs) -> tut E.^. TutorialCourse E.==. crs E.^. CourseId)
+        --     E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote)
+        --         E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid
+        --         E.&&. tut E.^. TutorialCourse E.!=. E.val cid
+        --         E.&&. crs E.^. CourseSchool E.==. E.val sid
+        --     E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantDayNote)
+        --     E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows']
+        --     E.limit maxSuggestions
+        --     pure (tpa E.^. TutorialParticipantDayNote, E.val 3)
+        )
+      E.groupBy (tpn, prio)
+      E.orderBy [E.asc prio, E.asc tpn]
+      E.limit maxSuggestions
+      pure $ E.coalesceDefault [tpn] $ E.val "" -- default never used due to where_ condtions, but conveniently changes type
+    --    $logInfoS "NOTE-SUGGS *** A: " $ tshow suggs
+    pure $ mkOptionListCacheable $ fmap Textarea . mkOptionText <$> nubOrd suggs -- TODO: datalist does not work on textarea inputs!
+  --      $logInfoS "NOTE-SUGGS *** B: " $ tshow ol
+  pure $ mkOptionListFromCacheable ol
 
-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
+colAttendanceField dday = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ (cellAttrs %~ addAttrsClass "text--center") <$> formCell id
   (views (resultParticipant . _entityKey) return)
   (\(preview (resultParticipantDay . _tutorialParticipantDayAttendance) -> attendance) mkUnique ->
     over (_1.mapped) (_dailyFormAttendance .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance
   )
 
 colAttendanceNoteField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
-colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:10%"), ("style","height:200px")]) <$> formCell id
+colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $  --  (cellAttrs <>~ [("style","width:10%"), ("style","height:200px")]) <$>
+  formCell id
   (views (resultParticipant . _entityKey) return)
-  (\(preview (resultParticipantDay . _tutorialParticipantDayNote) -> note) mkUnique ->
-    over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
-      mopt textareaField (fsUniq mkUnique "note-attendance"
+  (\row mkUnique ->
+    let note = row ^? resultParticipantDay . _tutorialParticipantDayNote
+        sid  = row ^. resultCourse . _entityVal . _courseSchool
+        cid  = row ^. resultCourse . _entityKey
+        tid  = row ^. resultTutorial . _entityKey
+    in over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
+      mopt  (textareaField & addDatalist (suggsAttendanceNote sid cid tid)) -- TODO: datalist does not work on textarea inputs!
+            (fsUniq mkUnique "note-attendance" & addClass' "uwx-short"
+                                          --   & addAttr "rows"  "2"      -- does not work without class uwx-short
+                                          --   & addAttr "cols" "12"      -- let it stretch
                                           --   & addAutosubmit -- submits while typing
-                           & addAttr "cols" "7"
-                           & addAttr "rows" "2" -- does not work if height is set via css (search "170px")
             ) (Textarea <<$>> note)
   )
 
@@ -372,7 +436,7 @@ colParkingField = colParkingField' _dailyFormParkingToken
 --   )
 
 colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
-colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell
+colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ (cellAttrs %~ addAttrsClass "text--center") <$> formCell
   id -- TODO: this should not be id! Refactor to simplify the thrid argument below
   (views (resultParticipant . _entityKey) return)
   (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique ->
@@ -380,8 +444,10 @@ colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToke
   )
 
 mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Widget)
-mkDailyTable isAdmin ssh nd = do
-  tutLessons <- getDayTutorials' ssh (nd,nd)
+mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case
+  tutLessons
+    | Map.null tutLessons -> return (FormMissing, [whamlet|No tutorials on this day|])
+    | otherwise -> do
       dday <- formatTime SelFormatDate nd
       let
         tutIds = Map.keys tutLessons
@@ -557,6 +623,7 @@ postSchoolDayR ssh nd = do
             , dailyFormParkingToken    = row ^? resultUserDay . _userDayParkingToken                      & fromMaybe False
             }
   (fmap unFormResult -> tableRes,tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd
+  $logInfoS "****DailyTable****" $ tshow tableRes
   formResult tableRes $ \resMap -> do
     runDB $ do
       forM_ (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do

src/Handler/Utils/Form.hs

@@ -1593,6 +1593,28 @@ optionsPersistCryptoId filts ords toDisplay = do
   ents <- runDB $ selectList filts ords
   optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal)
 
+mkOptionText :: E.Value Text -> Option Text
+mkOptionText (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
+
+mkOptionListText :: [E.Value Text] -> OptionList Text
+mkOptionListText = mkOptionList . fmap mkOptionText
+
+data OptionListCacheable a = OptionListCacheable [Option a] (Map Text a)
+deriving instance (Show a) => Show (OptionListCacheable a)
+deriving instance Generic (OptionListCacheable Text)
+deriving instance Binary  (OptionListCacheable Text)
+deriving instance Generic (OptionListCacheable Textarea)
+deriving instance Binary  (OptionListCacheable Textarea)
+
+mkOptionListCacheable :: [Option a] -> OptionListCacheable a
+mkOptionListCacheable ol = OptionListCacheable ol $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) ol
+
+mkOptionListFromCacheable :: OptionListCacheable a -> OptionList a
+mkOptionListFromCacheable (OptionListCacheable ol om) = OptionList
+  { olOptions      = ol
+  , olReadExternal = flip Map.lookup om
+  }
+
 mkOptionsE :: forall a r b msg.
               ( RenderMessage UniWorX msg
               , E.SqlSelect a r

src/Utils/Form.hs

@@ -185,6 +185,10 @@ addPlaceholder placeholder fs = fs { fsAttrs = (placeholderAttr, placeholder) :
 addClass :: PathPiece c => c -> FieldSettings site -> FieldSettings site
 addClass = over _fsAttrs . Yesod.addClass . toPathPiece
 
+-- for convenience
+addClass' :: Text -> FieldSettings site -> FieldSettings site
+addClass' = addClass
+
 addClasses :: (MonoFoldable mono, PathPiece (Element mono)) => mono -> FieldSettings site -> FieldSettings site
 addClasses = appEndo . foldMap (Endo . addClass)
 

src/Yesod/Form/Types/Instances.hs

@@ -7,10 +7,21 @@
 module Yesod.Form.Types.Instances
   () where
 
-import Yesod.Form.Types
-
-import Data.Default
+import ClassyPrelude.Yesod
+-- import Yesod.Form.Types
 
+-- import Data.Default
+import Data.Binary
 
 instance Default (FieldSettings site) where
   def = ""
+
+deriving instance (Show a) => Show (Option a)
+
+-- to memcache Option Text and Option Textarea
+deriving instance Generic (Option Text)
+deriving instance Binary  (Option Text)
+
+deriving newtype instance Binary  Textarea
+deriving instance Generic (Option Textarea)
+deriving instance Binary  (Option Textarea)