diff --git a/frontend/src/utils/inputs/inputs.sass b/frontend/src/utils/inputs/inputs.sass
index 8eda7ad8b..fb1a68069 100644
--- a/frontend/src/utils/inputs/inputs.sass
+++ b/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
diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs
index 853c3450c..bc4489737 100644
--- a/src/Handler/Admin/Avs.hs
+++ b/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
diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs
index e19945f1b..ccb15ae24 100644
--- a/src/Handler/Health/Interface.hs
+++ b/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
diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs
index e5c872494..62d0e5214 100644
--- a/src/Handler/Qualification.hs
+++ b/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 $
diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs
index 3fdf78ee0..1fe505234 100644
--- a/src/Handler/School/DayTasks.hs
+++ b/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)
--- 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 :: 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.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)
-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 $
- ( 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 :: Int64), 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 $ E.coalesceDefault [tpn] $ E.val ""
- mkOptionsE qry (pure . E.unValue) (pure . text2message . E.unValue) (pure . toPathPiece . E.unValue)
+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"
- -- & addAutosubmit -- submits while typing
- & addAttr "cols" "7"
- & addAttr "rows" "2" -- does not work if height is set via css (search "170px")
- ) (Textarea <<$>> note)
+ (\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
+ ) (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
- tutLessons <- getDayTutorials' ssh (nd,nd)
- dday <- formatTime SelFormatDate nd
- let
- tutIds = Map.keys tutLessons
- dbtSQLQuery :: DailyTableExpr -> DailyTableOutput
- dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs `E.LeftOuterJoin` udy `E.LeftOuterJoin` tdy) = do
- EL.on $ tut E.^. TutorialId E.=?. tdy E.?. TutorialParticipantDayTutorial
- E.&&. usr E.^. UserId E.=?. tdy E.?. TutorialParticipantDayUser
- E.&&. E.val nd E.=?. tdy E.?. TutorialParticipantDayDay
- EL.on $ usr E.^. UserId E.=?. udy E.?. UserDayUser
- E.&&. E.val nd E.=?. udy E.?. UserDayDay
- EL.on $ usr E.^. UserId E.=?. avs E.?. UserAvsUser
- EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser
- EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial
- EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId
- E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds
- let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do
- E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId
- let cqQual = cq E.^. CourseQualificationQualification
- cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual]
- return $ E.arrayAggWith E.AggModeAll cqQual cqOrder
- return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications)
- dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId)
- dbtProj = dbtProjId
- dbtColonnade = formColonnade $ mconcat
- [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey))
- 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
- , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons
- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) ->
- -- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell
- cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ Map.lookup tutId tutLessons
- -- , 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 Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell
- -- , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid
- -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid
- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row ->
- let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany
- primComp = row ^? resultCompanyId
- bookLink = cellMaybe companyIdCell bookComp
- result
- | primComp /= bookComp
- , Just (unCompanyKey -> csh) <- primComp
- = bookLink
- <> spacerCell
- <> 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|
- --
- -- ^{userWidget row}
- --
- -- _{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
- , colParticipantPermitField
- , colParticipantEyeExamField
- , colParticipantNoteField
- , colAttendanceField dday
- , colAttendanceNoteField dday
- , colParkingField
- -- FOR DEBUGGING ONLY
- -- , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell
- -- , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> x & cellMaybe i18nCell
- -- , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> x & cellMaybe textCell
- -- , 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
- -- , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell
- ]
- dbtSorting = Map.fromList
- [ sortUserNameLink queryUser
- , sortUserMatriclenr queryUser
- , ("course" , SortColumn $ queryCourse >>> (E.^. CourseName))
- , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName))
- , ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime)
- , ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany))
- , ("card-no" , SortColumn $ queryUserAvs >>> (E.?. UserAvsLastCardNo))
- , ("permit" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantDrivingPermit))
- , ("eye-exam" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantEyeExam))
- , ("note-tutorial" , SortColumn $ queryParticipant >>> (E.^. TutorialParticipantNote))
- , ("attendance" , SortColumnNullsInv $ queryParticipantDay >>> (E.?. TutorialParticipantDayAttendance))
- , ("note-attend" , SortColumn $ queryParticipantDay >>> (E.?. TutorialParticipantDayNote))
- , ("parking" , SortColumnNullsInv $ queryUserDay >>> (E.?. UserDayParkingToken))
- ]
- dbtFilter = Map.fromList
- [ fltrUserNameEmail queryUser
- , fltrUserMatriclenr queryUser
- , ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName))
- , ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName))
- , ("user-company" , FilterColumn . E.mkContainsFilter $ queryUser >>> selectCompanyUserPrime)
- ]
- dbtFilterUI mPrev = mconcat
- [ prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgFilterCourse)
- , prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCourseTutorial)
- , prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTablePrimeCompany)
- , fltrUserNameEmailUI mPrev
- , fltrUserMatriclenrUI mPrev
- ]
- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
- dbtIdent :: Text
- dbtIdent = "daily"
- dbtCsvEncode = noCsvEncode
- dbtCsvDecode = Nothing
- dbtExtraReps = []
- dbtParams = def { dbParamsFormAction = Just $ SomeRoute $ SchoolR ssh $ SchoolDayR nd }
- -- dbtParams = DBParamsForm
- -- { dbParamsFormMethod = POST
- -- , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
- -- , dbParamsFormAttrs = []
- -- , dbParamsFormSubmit = FormSubmit
- -- , dbParamsFormAdditional = \frag -> do
- -- let acts :: Map DailyTableAction (AForm Handler DailyTableActionData)
- -- acts = mconcat
- -- [ singletonMap DailyActDummy $ pure DailyActDummyData
- -- ]
- -- (actionRes, action) <- multiActionM acts "" Nothing mempty
- -- return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
- -- -- , dbParamsFormAdditional
- -- -- = let acts :: Map DailyTableAction (AForm Handler DailyTableActionData)
- -- -- acts = mconcat
- -- -- [ singletonMap DailyActDummy $ pure DailyActDummyData
- -- -- ]
- -- -- in renderAForm FormStandard
- -- -- $ (, mempty) . First . Just
- -- -- <$> multiActionA acts (fslI MsgTableAction) Nothing
- -- , dbParamsFormEvaluate = liftHandler . runFormPost
- -- , dbParamsFormResult = _1
- -- , dbParamsFormIdent = def
- -- }
- -- postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialParticipantId Bool DailyTableData)
- -- -> FormResult ( DailyTableActionData, Set TutorialId)
- -- postprocess inp = do
- -- (First (Just act), jobMap) <- inp
- -- let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
- -- return (act, jobSet)
- psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"]
- -- over _1 postprocess <$> dbTable psValidator DBTable{..}
- dbTable psValidator DBTable{..}
+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
+ dbtSQLQuery :: DailyTableExpr -> DailyTableOutput
+ dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs `E.LeftOuterJoin` udy `E.LeftOuterJoin` tdy) = do
+ EL.on $ tut E.^. TutorialId E.=?. tdy E.?. TutorialParticipantDayTutorial
+ E.&&. usr E.^. UserId E.=?. tdy E.?. TutorialParticipantDayUser
+ E.&&. E.val nd E.=?. tdy E.?. TutorialParticipantDayDay
+ EL.on $ usr E.^. UserId E.=?. udy E.?. UserDayUser
+ E.&&. E.val nd E.=?. udy E.?. UserDayDay
+ EL.on $ usr E.^. UserId E.=?. avs E.?. UserAvsUser
+ EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser
+ EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial
+ EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId
+ E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds
+ let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do
+ E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId
+ let cqQual = cq E.^. CourseQualificationQualification
+ cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual]
+ return $ E.arrayAggWith E.AggModeAll cqQual cqOrder
+ return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications)
+ dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId)
+ dbtProj = dbtProjId
+ dbtColonnade = formColonnade $ mconcat
+ [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey))
+ 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
+ , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons
+ , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) ->
+ -- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell
+ cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ Map.lookup tutId tutLessons
+ -- , 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 Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell
+ -- , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid
+ -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid
+ , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row ->
+ let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany
+ primComp = row ^? resultCompanyId
+ bookLink = cellMaybe companyIdCell bookComp
+ result
+ | primComp /= bookComp
+ , Just (unCompanyKey -> csh) <- primComp
+ = bookLink
+ <> spacerCell
+ <> 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|
+ --
+ -- ^{userWidget row}
+ --
+ -- _{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
+ , colParticipantPermitField
+ , colParticipantEyeExamField
+ , colParticipantNoteField
+ , colAttendanceField dday
+ , colAttendanceNoteField dday
+ , colParkingField
+ -- FOR DEBUGGING ONLY
+ -- , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell
+ -- , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> x & cellMaybe i18nCell
+ -- , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> x & cellMaybe textCell
+ -- , 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
+ -- , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell
+ ]
+ dbtSorting = Map.fromList
+ [ sortUserNameLink queryUser
+ , sortUserMatriclenr queryUser
+ , ("course" , SortColumn $ queryCourse >>> (E.^. CourseName))
+ , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName))
+ , ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime)
+ , ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany))
+ , ("card-no" , SortColumn $ queryUserAvs >>> (E.?. UserAvsLastCardNo))
+ , ("permit" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantDrivingPermit))
+ , ("eye-exam" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantEyeExam))
+ , ("note-tutorial" , SortColumn $ queryParticipant >>> (E.^. TutorialParticipantNote))
+ , ("attendance" , SortColumnNullsInv $ queryParticipantDay >>> (E.?. TutorialParticipantDayAttendance))
+ , ("note-attend" , SortColumn $ queryParticipantDay >>> (E.?. TutorialParticipantDayNote))
+ , ("parking" , SortColumnNullsInv $ queryUserDay >>> (E.?. UserDayParkingToken))
+ ]
+ dbtFilter = Map.fromList
+ [ fltrUserNameEmail queryUser
+ , fltrUserMatriclenr queryUser
+ , ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName))
+ , ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName))
+ , ("user-company" , FilterColumn . E.mkContainsFilter $ queryUser >>> selectCompanyUserPrime)
+ ]
+ dbtFilterUI mPrev = mconcat
+ [ prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgFilterCourse)
+ , prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCourseTutorial)
+ , prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTablePrimeCompany)
+ , fltrUserNameEmailUI mPrev
+ , fltrUserMatriclenrUI mPrev
+ ]
+ dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
+ dbtIdent :: Text
+ dbtIdent = "daily"
+ dbtCsvEncode = noCsvEncode
+ dbtCsvDecode = Nothing
+ dbtExtraReps = []
+ dbtParams = def { dbParamsFormAction = Just $ SomeRoute $ SchoolR ssh $ SchoolDayR nd }
+ -- dbtParams = DBParamsForm
+ -- { dbParamsFormMethod = POST
+ -- , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
+ -- , dbParamsFormAttrs = []
+ -- , dbParamsFormSubmit = FormSubmit
+ -- , dbParamsFormAdditional = \frag -> do
+ -- let acts :: Map DailyTableAction (AForm Handler DailyTableActionData)
+ -- acts = mconcat
+ -- [ singletonMap DailyActDummy $ pure DailyActDummyData
+ -- ]
+ -- (actionRes, action) <- multiActionM acts "" Nothing mempty
+ -- return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
+ -- -- , dbParamsFormAdditional
+ -- -- = let acts :: Map DailyTableAction (AForm Handler DailyTableActionData)
+ -- -- acts = mconcat
+ -- -- [ singletonMap DailyActDummy $ pure DailyActDummyData
+ -- -- ]
+ -- -- in renderAForm FormStandard
+ -- -- $ (, mempty) . First . Just
+ -- -- <$> multiActionA acts (fslI MsgTableAction) Nothing
+ -- , dbParamsFormEvaluate = liftHandler . runFormPost
+ -- , dbParamsFormResult = _1
+ -- , dbParamsFormIdent = def
+ -- }
+ -- postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialParticipantId Bool DailyTableData)
+ -- -> FormResult ( DailyTableActionData, Set TutorialId)
+ -- postprocess inp = do
+ -- (First (Just act), jobMap) <- inp
+ -- let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
+ -- return (act, jobSet)
+ 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
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index f99b6f37a..3557b9c54 100644
--- a/src/Handler/Utils/Form.hs
+++ b/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
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 1f88144d6..39f7bf88c 100644
--- a/src/Utils/Form.hs
+++ b/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)
diff --git a/src/Yesod/Form/Types/Instances.hs b/src/Yesod/Form/Types/Instances.hs
index 518fcd9ee..fef720bec 100644
--- a/src/Yesod/Form/Types/Instances.hs
+++ b/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)
\ No newline at end of file