From 8317f682d8ffd0c42434c6def19b881bea9bde0c Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 23 Oct 2024 16:12:18 +0200 Subject: [PATCH] chore(tutorial): (WIP) towards #90 write form columns --- src/Handler/School/DayTasks.hs | 58 ++++++++++++++++++++++++++++++---- src/Model/Types/User.hs | 3 +- test/Model/TypesSpec.hs | 4 +-- 3 files changed, 56 insertions(+), 9 deletions(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index c523eb3c3..ddc3fbc04 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -20,7 +20,7 @@ import Handler.Utils.Occurrences import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Aeson as Aeson --- import qualified Data.Text as Text +import qualified Data.Text as Text -- import Database.Persist.Sql (updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) @@ -227,6 +227,51 @@ instance HasUser DailyTableData where -- see colRatedField' for an example of formCell usage +drivingPermitField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserDrivingPermit +drivingPermitField = selectField' Nothing optionsFinite + +-- eyeExamField :: Field (HandlerFor UniWorX) UserEyeExam +-- eyeExamField = selectField optionsFinite + +-- This does not type: +-- colParticipantPermitField :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +-- colParticipantPermitField l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table +-- (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result +-- (\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique -> +-- over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit") $ Just x +-- ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + +-- colEyeExamField :: TODO + +colParticipantNoteField :: ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colParticipantNoteField l = sortable (Just "note-participant") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table + (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result + (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique -> + over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> + mopt textareaField (fsUniq mkUnique "note-participant") (Just $ Textarea <$> note) + ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + +colAttendanceField :: Text -> ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colAttendanceField dday l = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table + (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result + (\(preview (resultParticipantDay . _tutorialParticipantDayAttendance) -> attendance) mkUnique -> + over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance + ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + +colAttendnaceNoteField :: Text -> ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colAttendnaceNoteField dday l = sortable (Just "note-attendance") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table + (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result + (\(preview (resultParticipantDay . _tutorialParticipantDayNote) -> note) mkUnique -> + over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> + mopt textareaField (fsUniq mkUnique "note-attendance") (Textarea <<$>> note) + ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + +colParkingField :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colParkingField l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table + (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result + (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique -> + over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking + ) -- Given the row data and a callback to make an input name suitably unique generate the MForm mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) mkDailyTable isAdmin ssh nd = do @@ -273,12 +318,13 @@ mkDailyTable isAdmin ssh nd = do , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn - , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> maybeCell x $ textCell . tshow - , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> maybeCell x $ textCell . tshow - , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> maybeCell x textCell - , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> maybeCell x tickmarkCell - , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> maybeCell x textCell + , 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 + -- , colParkingField id ] dbtSorting = Map.fromList [ sortUserNameLink queryUser diff --git a/src/Model/Types/User.hs b/src/Model/Types/User.hs index b7fec9225..0abcd42af 100644 --- a/src/Model/Types/User.hs +++ b/src/Model/Types/User.hs @@ -45,7 +45,7 @@ deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } ''UserDrivingPermit derivePersistFieldJSON ''UserDrivingPermit - +nullaryPathPiece ''UserDrivingPermit $ camelToPathPiece' 3 data UserEyeExam = UserEyeExamSX | UserEyeExamS01 @@ -62,3 +62,4 @@ deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } ''UserEyeExam derivePersistFieldJSON ''UserEyeExam +nullaryPathPiece ''UserEyeExam $ camelToPathPiece' 3 diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 0b271c547..4939b4f2f 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -546,9 +546,9 @@ spec = do lawsCheckHspec (Proxy @LmsDay) [ eqLaws, ordLaws, showLaws, showReadLaws, csvFieldLaws ] lawsCheckHspec (Proxy @UserDrivingPermit) - [ eqLaws, ordLaws, showLaws, boundedEnumLaws, finiteLaws, persistFieldLaws ] + [ eqLaws, ordLaws, showLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, persistFieldLaws ] lawsCheckHspec (Proxy @UserEyeExam) - [ eqLaws, ordLaws, showLaws, boundedEnumLaws, finiteLaws, persistFieldLaws ] + [ eqLaws, ordLaws, showLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, persistFieldLaws ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $