chore(tutorial): (WIP) towards #90 write form columns

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 "permit")        (i18nCell   MsgTutorialDrivingPermit)      $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell
-      , sortable (Just "eye-exam")      (i18nCell   MsgTutorialEyeExam)            $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam       -> x) -> maybeCell x $ textCell . tshow
+      , 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) -> maybeCell x textCell
+      , sortable (Just "note-tutorial") (i18nCell   MsgTutorialNote)               $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote          -> x) -> x & cellMaybe textCell
-      , sortable (Just "attendance")    (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance        -> 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) -> maybeCell x textCell
+      , 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

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

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 $