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__)
+      suggestionsBlock   = mkOptionListText <$> runDBRead (getBlockReasons E.not__)
-      suggestionsUnblock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons id)
+      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_)
+        suggestionsBlock   = mkOptionListText <$> runDB (getBlockReasons Ex.not_)
-        suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
+        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,75 +290,139 @@ 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)
+suggsParticipantNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text)
--- deriving instance (Binary a, Generic a) => Binary (OptionList a)
+suggsParticipantNote sid cid tid = do
--- deriving instance Generic (OptionList Text)
+  ol <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough?
--- deriving instance Binary  (OptionList Text)
+    suggs <- runDB $ E.select $ do
-deriving instance Generic (Option Text)
+      let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
-deriving instance Binary (Option Text)
+      (tpn, prio) <- E.from $
+        ( do
+            tpa <- E.from $ E.table @TutorialParticipant
+            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 (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.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
+                E.&&. tpa E.^. TutorialParticipantTutorial E.!=. E.val tid
+                E.&&. tut E.^. TutorialCourse E.==. E.val cid
+            E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantNote)
+            E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows']
+            E.limit maxSuggestions
+            pure (tpa E.^. TutorialParticipantNote, E.val 2)
+        ) `E.unionAll_`
+        ( do
+            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 (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 "" -- 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
 
-suggsParticipantNote :: CourseId -> TutorialId -> Handler (OptionList Text)
+suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Textarea)
-suggsParticipantNote cid tid = $(memcachedByHere) (Just . Right $ 12 * diffSecond) (cid,tid) $ runDB $ do -- TODO: better memcached key
+suggsAttendanceNote sid cid tid = do
-  let qry :: E.SqlQuery (E.SqlExpr (E.Value Text)) = do
+  ol <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough?
-        (prio, tpn) <- E.from $
+    suggs <- runDB $ E.select $ do
-          ( do
+      let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
-              tpa <- E.from $ E.table @TutorialParticipant
+      (tpn, prio) <- E.from $
-              E.distinct $ pure ()
+        ( do
-              E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
+            tpa <- E.from $ E.table @TutorialParticipantDay
-                  E.&&.  tpa E.^. TutorialParticipantTutorial E.==. E.val tid
+            E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote)
-              E.limit maxSuggestions
+                E.&&.  tpa E.^. TutorialParticipantDayTutorial E.==. E.val tid
-              pure (E.val (1 :: Int64), tpa E.^. TutorialParticipantNote)
+            E.groupBy (tpa E.^. TutorialParticipantDayNote, tpa E.^. TutorialParticipantDayDay)
-          ) `E.unionAll_`
+            E.orderBy [E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc countRows']
-          ( do
+            E.limit maxSuggestions
-              (tpa :& tut) <- E.from $  E.table @TutorialParticipant
+            pure (tpa E.^. TutorialParticipantDayNote, E.val (1 :: Int64))
-                          `E.innerJoin` E.table @Tutorial
+        -- ) `E.unionAll_`
-                          `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial)
+        -- ( do
-              E.distinct $ pure ()
+        --     (tpa :& tut) <- E.from $  E.table @TutorialParticipantDay
-              E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
+        --                 `E.innerJoin` E.table @Tutorial
-                  E.&&.   tut E.^. TutorialCourse E.==. E.val cid
+        --                 `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial)
-              E.orderBy [E.desc $ tut E.^. TutorialLastChanged]
+        --     E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote)
-              E.limit maxSuggestions
+        --         E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid
-              pure (E.val 2, tpa E.^. TutorialParticipantNote)
+        --         E.&&. tut E.^. TutorialCourse E.==. E.val cid
-          ) `E.unionAll_`
+        --     E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantDayNote)
-          ( do
+        --     E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc countRows']
-              tpa <- E.from $ E.table @TutorialParticipant
+        --     E.limit maxSuggestions
-              E.distinct $ pure ()
+        --     pure (tpa E.^. TutorialParticipantDayNote, E.val 2)
-              E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
+        -- ) `E.unionAll_`
-              E.limit maxSuggestions
+        -- ( do
-              pure (E.val 3, tpa E.^. TutorialParticipantNote)
+        --     tpa :& tut :& crs <- E.from $ E.table @TutorialParticipantDay
-          )
+        --                 `E.innerJoin` E.table @Tutorial
-        E.orderBy [E.asc prio, E.asc tpn]
+        --                 `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial)
-        E.limit maxSuggestions
+        --                 `E.innerJoin` E.table @Course
-        pure $ E.coalesceDefault [tpn] $ E.val ""
+        --                 `E.on` (\(_ :& tut :& crs) -> tut E.^. TutorialCourse E.==. crs E.^. CourseId)
-  mkOptionsE qry (pure . E.unValue) (pure . text2message . E.unValue) (pure . toPathPiece . E.unValue)
+        --     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 ->
+  (\row mkUnique ->
-    over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
+    let note = row ^? resultParticipantDay . _tutorialParticipantDayNote
-      mopt textareaField (fsUniq mkUnique "note-attendance"
+        sid  = row ^. resultCourse . _entityVal . _courseSchool
-                      --   & addAutosubmit -- submits while typing
+        cid  = row ^. resultCourse . _entityKey
-                           & addAttr "cols" "7"
+        tid  = row ^. resultTutorial . _entityKey
-                           & addAttr "rows" "2" -- does not work if height is set via css (search "170px")
+    in over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
-                          ) (Textarea <<$>> note)
+      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
+            ) (Textarea <<$>> note)
   )
 
 colParkingField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
@@ -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,166 +444,168 @@ colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToke
   )
 
 mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Widget)
-mkDailyTable isAdmin ssh nd = do
+mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case
-  tutLessons <- getDayTutorials' ssh (nd,nd)
+  tutLessons
-  dday <- formatTime SelFormatDate nd
+    | Map.null tutLessons -> return (FormMissing, [whamlet|No tutorials on this day|])
-  let
+    | otherwise -> do
-    tutIds = Map.keys tutLessons
+      dday <- formatTime SelFormatDate nd
-    dbtSQLQuery :: DailyTableExpr -> DailyTableOutput
+      let
-    dbtSQLQuery  (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs `E.LeftOuterJoin` udy `E.LeftOuterJoin` tdy) = do
+        tutIds = Map.keys tutLessons
-      EL.on $ tut E.^. TutorialId     E.=?. tdy E.?. TutorialParticipantDayTutorial
+        dbtSQLQuery :: DailyTableExpr -> DailyTableOutput
-        E.&&. usr E.^. UserId         E.=?. tdy E.?. TutorialParticipantDayUser
+        dbtSQLQuery  (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs `E.LeftOuterJoin` udy `E.LeftOuterJoin` tdy) = do
-        E.&&. E.val nd                E.=?. tdy E.?. TutorialParticipantDayDay
+          EL.on $ tut E.^. TutorialId     E.=?. tdy E.?. TutorialParticipantDayTutorial
-      EL.on $ usr E.^. UserId         E.=?. udy E.?. UserDayUser
+            E.&&. usr E.^. UserId         E.=?. tdy E.?. TutorialParticipantDayUser
-        E.&&. E.val nd                E.=?. udy E.?. UserDayDay
+            E.&&. E.val nd                E.=?. tdy E.?. TutorialParticipantDayDay
-      EL.on $ usr E.^. UserId         E.=?. avs E.?. UserAvsUser
+          EL.on $ usr E.^. UserId         E.=?. udy E.?. UserDayUser
-      EL.on $ usr E.^. UserId         E.==. tpu E.^. TutorialParticipantUser
+            E.&&. E.val nd                E.=?. udy E.?. UserDayDay
-      EL.on $ tut E.^. TutorialId     E.==. tpu E.^. TutorialParticipantTutorial
+          EL.on $ usr E.^. UserId         E.=?. avs E.?. UserAvsUser
-      EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId
+          EL.on $ usr E.^. UserId         E.==. tpu E.^. TutorialParticipantUser
-      E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds
+          EL.on $ tut E.^. TutorialId     E.==. tpu E.^. TutorialParticipantTutorial
-      let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do
+          EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId
-            E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId
+          E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds
-            let cqQual  = cq E.^. CourseQualificationQualification
+          let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do
-                cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual]
+                E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId
-            return $ E.arrayAggWith E.AggModeAll cqQual cqOrder
+                let cqQual  = cq E.^. CourseQualificationQualification
-      return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications)
+                    cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual]
-    dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId)
+                return $ E.arrayAggWith E.AggModeAll cqQual cqOrder
-    dbtProj   = dbtProjId
+          return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications)
-    dbtColonnade = formColonnade $ mconcat
+        dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId)
-      [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey))
+        dbtProj   = dbtProjId
-        sortable (Just "course")    (i18nCell MsgFilterCourse)     $ \(view $ resultCourse . _entityVal -> c) -> courseCell c
+        dbtColonnade = formColonnade $ mconcat
-      , sortable (Just "tutorial")  (i18nCell MsgCourseTutorial)   $ \row ->
+          [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey))
-          let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh}
+            sortable (Just "course")    (i18nCell MsgFilterCourse)     $ \(view $ resultCourse . _entityVal -> c) -> courseCell c
-                      = row ^. resultCourse   . _entityVal
+          , sortable (Just "tutorial")  (i18nCell MsgCourseTutorial)   $ \row ->
-              tutName = row ^. resultTutorial . _entityVal . _tutorialName
+              let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh}
-          in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName
+                          = row ^. resultCourse   . _entityVal
-      , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons
+                  tutName = row ^. resultTutorial . _entityVal . _tutorialName
-      , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) ->
+              in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName
-          -- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell
+          , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons
-          cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ Map.lookup tutId tutLessons
+          , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) ->
-      -- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now
+              -- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell
-      , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell
+              cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ Map.lookup tutId tutLessons
-      -- , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid
+          -- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now
-      -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid
+          , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell
-      , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row ->
+          -- , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid
-          let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany
+          -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid
-              primComp = row ^? resultCompanyId
+          , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row ->
-              bookLink = cellMaybe companyIdCell bookComp
+              let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany
-              result
+                  primComp = row ^? resultCompanyId
-                | primComp /= bookComp
+                  bookLink = cellMaybe companyIdCell bookComp
-                , Just (unCompanyKey -> csh) <- primComp
+                  result
-                  = bookLink
+                    | primComp /= bookComp
-                  <> spacerCell
+                    , Just (unCompanyKey -> csh) <- primComp
-                  <> cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|]
+                      = bookLink
-                          (Just IconCompanyWarning) True)
+                      <> spacerCell
-                | otherwise = bookLink
+                      <> cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|]
-          in result
+                              (Just IconCompanyWarning) True)
-      -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row ->
+                    | otherwise = bookLink
-      --     let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany
+              in result
-      --         primComp = row ^? resultCompanyId
+          -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row ->
-      --         bookLink = cellMaybe companyIdCell bookComp
+          --     let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany
-      --         warnIcon = \csh -> iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] (Just IconCompanyWarning) True
+          --         primComp = row ^? resultCompanyId
-      --         result
+          --         bookLink = cellMaybe companyIdCell bookComp
-      --           | primComp /= bookComp
+          --         warnIcon = \csh -> iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] (Just IconCompanyWarning) True
-      --           , Just (unCompanyKey -> csh) <- primComp
+          --         result
-      --             = bookLink
+          --           | primComp /= bookComp
-      --             <> spacerCell
+          --           , Just (unCompanyKey -> csh) <- primComp
-      --             <> cell (modal (warnIcon csh) (Right -- TODO: use iconCompanyWarning instead!
+          --             = bookLink
-      --                 [whamlet|
+          --             <> spacerCell
-      --                   <h2>
+          --             <> cell (modal (warnIcon csh) (Right -- TODO: use iconCompanyWarning instead!
-      --                     ^{userWidget row}
+          --                 [whamlet|
-      --                   <p>
+          --                   <h2>
-      --                     _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}
+          --                     ^{userWidget row}
-      --                 |]
+          --                   <p>
-      --                 ))
+          --                     _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}
-      --           | otherwise = bookLink
+          --                 |]
-      --     in result
+          --                 ))
-      , colUserNameModalHdr MsgCourseParticipant ForProfileDataR
+          --           | otherwise = bookLink
-      , colUserMatriclenr isAdmin
+          --     in result
-      , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn
+          , colUserNameModalHdr MsgCourseParticipant ForProfileDataR
-      , colParticipantPermitField
+          , colUserMatriclenr isAdmin
-      , colParticipantEyeExamField
+          , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn
-      , colParticipantNoteField
+          , colParticipantPermitField
-      , colAttendanceField     dday
+          , colParticipantEyeExamField
-      , colAttendanceNoteField dday
+          , colParticipantNoteField
-      , colParkingField
+          , colAttendanceField     dday
-      -- FOR DEBUGGING ONLY
+          , colAttendanceNoteField dday
-      -- , sortable (Just "permit")        (i18nCell   MsgTutorialDrivingPermit)      $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell
+          , colParkingField
-      -- , sortable (Just "eye-exam")      (i18nCell   MsgTutorialEyeExam)            $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam       -> x) -> x & cellMaybe i18nCell
+          -- FOR DEBUGGING ONLY
-      -- , sortable (Just "note-tutorial") (i18nCell   MsgTutorialNote)               $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote          -> x) -> x & cellMaybe textCell
+          -- , sortable (Just "permit")        (i18nCell   MsgTutorialDrivingPermit)      $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell
-      -- , sortable (Just "attendance")    (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance        -> x) -> x & cellMaybe tickmarkCell
+          -- , sortable (Just "eye-exam")      (i18nCell   MsgTutorialEyeExam)            $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam       -> x) -> x & cellMaybe i18nCell
-      -- , sortable (Just "note-attend")   (i18nCell $ MsgTutorialDayNote       dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just      -> x) -> x & cellMaybe textCell
+          -- , sortable (Just "note-tutorial") (i18nCell   MsgTutorialNote)               $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote          -> x) -> x & cellMaybe textCell
-      -- , sortable (Just "parking")       (i18nCell   MsgTableUserParkingToken)      $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell
+          -- , sortable (Just "attendance")    (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance        -> x) -> x & cellMaybe tickmarkCell
-      ]
+          -- , sortable (Just "note-attend")   (i18nCell $ MsgTutorialDayNote       dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just      -> x) -> x & cellMaybe textCell
-    dbtSorting = Map.fromList
+          -- , sortable (Just "parking")       (i18nCell   MsgTableUserParkingToken)      $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell
-      [ sortUserNameLink queryUser
+          ]
-      , sortUserMatriclenr  queryUser
+        dbtSorting = Map.fromList
-      , ("course"         , SortColumn $ queryCourse      >>> (E.^. CourseName))
+          [ sortUserNameLink queryUser
-      , ("tutorial"       , SortColumn $ queryTutorial    >>> (E.^. TutorialName))
+          , sortUserMatriclenr  queryUser
-      , ("user-company"   , SortColumn $ queryUser        >>> selectCompanyUserPrime)
+          , ("course"         , SortColumn $ queryCourse      >>> (E.^. CourseName))
-      , ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany))
+          , ("tutorial"       , SortColumn $ queryTutorial    >>> (E.^. TutorialName))
-      , ("card-no"        , SortColumn $ queryUserAvs     >>> (E.?. UserAvsLastCardNo))
+          , ("user-company"   , SortColumn $ queryUser        >>> selectCompanyUserPrime)
-      , ("permit"         , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantDrivingPermit))
+          , ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany))
-      , ("eye-exam"       , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantEyeExam))
+          , ("card-no"        , SortColumn $ queryUserAvs     >>> (E.?. UserAvsLastCardNo))
-      , ("note-tutorial"  , SortColumn         $ queryParticipant >>> (E.^. TutorialParticipantNote))
+          , ("permit"         , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantDrivingPermit))
-      , ("attendance"     , SortColumnNullsInv $ queryParticipantDay >>> (E.?. TutorialParticipantDayAttendance))
+          , ("eye-exam"       , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantEyeExam))
-      , ("note-attend"    , SortColumn         $ queryParticipantDay >>> (E.?. TutorialParticipantDayNote))
+          , ("note-tutorial"  , SortColumn         $ queryParticipant >>> (E.^. TutorialParticipantNote))
-      , ("parking"        , SortColumnNullsInv $ queryUserDay     >>> (E.?. UserDayParkingToken))
+          , ("attendance"     , SortColumnNullsInv $ queryParticipantDay >>> (E.?. TutorialParticipantDayAttendance))
-      ]
+          , ("note-attend"    , SortColumn         $ queryParticipantDay >>> (E.?. TutorialParticipantDayNote))
-    dbtFilter = Map.fromList
+          , ("parking"        , SortColumnNullsInv $ queryUserDay     >>> (E.?. UserDayParkingToken))
-      [ fltrUserNameEmail   queryUser
+          ]
-      , fltrUserMatriclenr  queryUser
+        dbtFilter = Map.fromList
-      , ("course"       , FilterColumn . E.mkContainsFilter $ queryCourse   >>> (E.^. CourseName))
+          [ fltrUserNameEmail   queryUser
-      , ("tutorial"     , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName))
+          , fltrUserMatriclenr  queryUser
-      , ("user-company" , FilterColumn . E.mkContainsFilter $ queryUser     >>> selectCompanyUserPrime)
+          , ("course"       , FilterColumn . E.mkContainsFilter $ queryCourse   >>> (E.^. CourseName))
-      ]
+          , ("tutorial"     , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName))
-    dbtFilterUI mPrev = mconcat
+          , ("user-company" , FilterColumn . E.mkContainsFilter $ queryUser     >>> selectCompanyUserPrime)
-      [ prismAForm (singletonFilter "course"       . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgFilterCourse)
+          ]
-      , prismAForm (singletonFilter "tutorial"     . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCourseTutorial)
+        dbtFilterUI mPrev = mconcat
-      , prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgTablePrimeCompany)
+          [ prismAForm (singletonFilter "course"       . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgFilterCourse)
-      , fltrUserNameEmailUI  mPrev
+          , prismAForm (singletonFilter "tutorial"     . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCourseTutorial)
-      , fltrUserMatriclenrUI mPrev
+          , prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgTablePrimeCompany)
-      ]
+          , fltrUserNameEmailUI  mPrev
-    dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
+          , fltrUserMatriclenrUI mPrev
-    dbtIdent :: Text
+          ]
-    dbtIdent = "daily"
+        dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
-    dbtCsvEncode = noCsvEncode
+        dbtIdent :: Text
-    dbtCsvDecode = Nothing
+        dbtIdent = "daily"
-    dbtExtraReps = []
+        dbtCsvEncode = noCsvEncode
-    dbtParams    = def { dbParamsFormAction = Just $ SomeRoute $ SchoolR ssh $ SchoolDayR nd }
+        dbtCsvDecode = Nothing
-    -- dbtParams = DBParamsForm
+        dbtExtraReps = []
-    --   { dbParamsFormMethod = POST
+        dbtParams    = def { dbParamsFormAction = Just $ SomeRoute $ SchoolR ssh $ SchoolDayR nd }
-    --   , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
+        -- dbtParams = DBParamsForm
-    --   , dbParamsFormAttrs  = []
+        --   { dbParamsFormMethod = POST
-    --   , dbParamsFormSubmit = FormSubmit
+        --   , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
-    --   , dbParamsFormAdditional = \frag -> do
+        --   , dbParamsFormAttrs  = []
-    --       let acts :: Map DailyTableAction (AForm Handler DailyTableActionData)
+        --   , dbParamsFormSubmit = FormSubmit
-    --           acts = mconcat
+        --   , dbParamsFormAdditional = \frag -> do
-    --                   [ singletonMap DailyActDummy $ pure DailyActDummyData
+        --       let acts :: Map DailyTableAction (AForm Handler DailyTableActionData)
-    --                    ]
+        --           acts = mconcat
-    --       (actionRes, action) <- multiActionM acts "" Nothing mempty
+        --                   [ singletonMap DailyActDummy $ pure DailyActDummyData
-    --       return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
+        --                    ]
-    --   -- , dbParamsFormAdditional
+        --       (actionRes, action) <- multiActionM acts "" Nothing mempty
-    --   --     = let acts :: Map DailyTableAction (AForm Handler DailyTableActionData)
+        --       return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
-    --   --           acts = mconcat
+        --   -- , dbParamsFormAdditional
-    --   --             [ singletonMap DailyActDummy $ pure DailyActDummyData
+        --   --     = let acts :: Map DailyTableAction (AForm Handler DailyTableActionData)
-    --   --             ]
+        --   --           acts = mconcat
-    --   --        in renderAForm FormStandard
+        --   --             [ singletonMap DailyActDummy $ pure DailyActDummyData
-    --   --          $  (, mempty) . First . Just
+        --   --             ]
-    --   --         <$> multiActionA acts (fslI MsgTableAction) Nothing
+        --   --        in renderAForm FormStandard
-    --   , dbParamsFormEvaluate = liftHandler . runFormPost
+        --   --          $  (, mempty) . First . Just
-    --   , dbParamsFormResult   = _1
+        --   --         <$> multiActionA acts (fslI MsgTableAction) Nothing
-    --   , dbParamsFormIdent    = def
+        --   , dbParamsFormEvaluate = liftHandler . runFormPost
-    --   }
+        --   , dbParamsFormResult   = _1
-    -- postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialParticipantId Bool DailyTableData)
+        --   , dbParamsFormIdent    = def
-    --             -> FormResult (      DailyTableActionData,          Set TutorialId)
+        --   }
-    -- postprocess inp = do
+        -- postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialParticipantId Bool DailyTableData)
-    --     (First (Just act), jobMap) <- inp
+        --             -> FormResult (      DailyTableActionData,          Set TutorialId)
-    --     let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
+        -- postprocess inp = do
-    --     return (act, jobSet)
+        --     (First (Just act), jobMap) <- inp
-    psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"]
+        --     let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
-  -- over _1 postprocess <$> dbTable psValidator DBTable{..}
+        --     return (act, jobSet)
-  dbTable psValidator DBTable{..}
+        psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"]
+      -- over _1 postprocess <$> dbTable psValidator DBTable{..}
+      dbTable psValidator DBTable{..}
 
 
 getSchoolDayR,  postSchoolDayR :: SchoolId -> Day -> Handler Html
@@ -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 ClassyPrelude.Yesod
-
+-- import Yesod.Form.Types
-import Data.Default
 
+-- 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)