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 "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

src/Model/Types/User.hs

@@ -38,11 +38,14 @@ instance Show UserDrivingPermit where
   show UserDrivingPermitB   = "B"
   show UserDrivingPermitB01 = "B01"
 
+instance RenderMessage a UserDrivingPermit where
+  renderMessage _foundation _languages = tshow
+
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece' 3
   } ''UserDrivingPermit
 derivePersistFieldJSON ''UserDrivingPermit
-
+nullaryPathPiece ''UserDrivingPermit $ camelToPathPiece' 3
 
 data UserEyeExam = UserEyeExamSX
                  | UserEyeExamS01
@@ -52,9 +55,11 @@ instance Show UserEyeExam where
   show UserEyeExamSX  = "SX"
   show UserEyeExamS01 = "S01"
 
+instance RenderMessage a UserEyeExam where
+  renderMessage _foundation _languages = tshow
+
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece' 3
   } ''UserEyeExam
 derivePersistFieldJSON ''UserEyeExam
-
-
+nullaryPathPiece ''UserEyeExam $ camelToPathPiece' 3

test/Handler/Utils/SubmissionSpec.hs

@@ -196,7 +196,7 @@ spec = withApp . describe "Submission distribution" $ do
             void . insert $ Tutor tutId sheetCorrectorUser
             E.insertSelect . E.from $ \submissionUser -> do
               E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
-              return $ TutorialParticipant E.<# E.val tutId E.<&> (submissionUser E.^. SubmissionUserUser) E.<&> E.nothing
+              return $ TutorialParticipant E.<# E.val tutId E.<&> (submissionUser E.^. SubmissionUserUser) E.<&> E.nothing E.<&> E.nothing E.<&> E.nothing E.<&> E.nothing
       )
       (\result -> do
           let countResult = Map.map Set.size result

test/Model/TypesSpec.hs

@@ -51,6 +51,7 @@ import Text.Blaze.TestInstances ()
 import qualified Data.Text.Lazy as LT
 
 import Text.Blaze.Html.Renderer.Text (renderHtml)
+import Text.Shakespeare.I18N (renderMessage)
 
 import qualified Data.SemVer as SemVer
 import qualified Data.SemVer.Constraint as SemVer (Constraint)
@@ -417,6 +418,12 @@ instance Arbitrary LmsDay where
 
 deriving newtype instance Arbitrary LmsIdent
 
+instance Arbitrary UserDrivingPermit where
+  arbitrary = genericArbitrary
+
+instance Arbitrary UserEyeExam where
+  arbitrary = genericArbitrary
+
 spec :: Spec
 spec = do
   parallel $ do
@@ -538,6 +545,10 @@ spec = do
       [ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, csvFieldLaws ]
     lawsCheckHspec (Proxy @LmsDay)
       [ eqLaws, ordLaws, showLaws, showReadLaws, csvFieldLaws ]
+    lawsCheckHspec (Proxy @UserDrivingPermit)
+      [ eqLaws, ordLaws, showLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @UserEyeExam)
+      [ eqLaws, ordLaws, showLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, persistFieldLaws ]
 
   describe "TermIdentifier" $ do
     it "has compatible encoding/decoding to/from Text" . property $
@@ -642,6 +653,20 @@ spec = do
       showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 0, byDeficit = 0 } CorrectorNormal  `shouldBe` "-D"
       showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 1, byDeficit = 0 } CorrectorMissing `shouldBe` "[1.0 - D]"
       showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 1, byDeficit = 0 } CorrectorExcused `shouldBe` "{1.0 - D}"
+  describe "UserDrivingPermit" $ do
+    it "encodes to DB as shown to user" . property $
+      \(v :: UserDrivingPermit) ->
+        let tv = tshow v
+        in  cmpJsonStringCI v tv && tv == renderMessage (error "renderMessage: foundation inspected") [] v
+  describe "UserEyeExam" $ do
+    it "encodes to DB as shown to user" . property $
+      \(v :: UserEyeExam) ->
+        let tv = tshow v
+        in  cmpJsonStringCI v tv && tv == renderMessage (error "renderMessage: foundation inspected") [] v
+  where
+    cmpJsonStringCI :: Aeson.ToJSON a => a -> Text -> Bool
+    cmpJsonStringCI (Aeson.toJSON -> Aeson.String s) t = CI.mk s == CI.mk t
+    cmpJsonStringCI _ _ = False
 
 termExample :: (TermIdentifier, Text) -> Expectation
 termExample (term, encoded) = example $ do

test/Utils/TypesSpec.hs

@@ -10,27 +10,27 @@ import Utils
 import qualified Data.Aeson as Aeson
 
 
-instance Arbitrary SloppyBool where 
+instance Arbitrary SloppyBool where
   arbitrary = SloppyBool <$> arbitrary
   shrink (SloppyBool x) = SloppyBool <$> shrink x
 
-instance Arbitrary AvsInternalPersonalNo where 
+instance Arbitrary AvsInternalPersonalNo where
   arbitrary = mkAvsInternalPersonalNo <$> arbitrary
   shrink (AvsInternalPersonalNo x) = mkAvsInternalPersonalNo <$> shrink x
 
-instance Arbitrary AvsPersonId where 
+instance Arbitrary AvsPersonId where
   arbitrary = AvsPersonId <$> arbitrary
   shrink (AvsPersonId x) = AvsPersonId <$> shrink x
 
-instance Arbitrary AvsCardNo where 
+instance Arbitrary AvsCardNo where
   arbitrary = AvsCardNo . normalizeAvsCardNo <$> arbitrary
   shrink (AvsCardNo x) = AvsCardNo . normalizeAvsCardNo <$> shrink x
 
-instance Arbitrary AvsLicence where 
+instance Arbitrary AvsLicence where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
-instance Arbitrary AvsObjPersonId where 
+instance Arbitrary AvsObjPersonId where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
@@ -39,7 +39,7 @@ instance Arbitrary AvsDataCardColor where
   shrink = genericShrink
 
 instance Arbitrary AvsDataPersonCard where
-  arbitrary = canonical <$> genericArbitrary    
+  arbitrary = canonical <$> genericArbitrary
   shrink = fmap canonical <$> genericShrink
 
 instance Arbitrary AvsStatusPerson where
@@ -63,7 +63,7 @@ instance Arbitrary AvsResponsePerson where
   shrink = genericShrink
 
 instance Arbitrary AvsResponseStatus where
-  arbitrary = genericArbitrary
+  arbitrary = resize 5 genericArbitrary
   shrink = genericShrink
 
 instance Arbitrary AvsResponseSetLicences where
@@ -125,7 +125,7 @@ spec = do
     lawsCheckHspec (Proxy @AvsQuerySetLicences)
       [ eqLaws, showLaws, jsonLaws]
 
-  describe "AvsLicence" $ do       
+  describe "AvsLicence" $ do
     it "ordering is consistent with its PersistField instance" . property $ -- this assumption is used in Handler.Utils.Avs.synchAvsLicences
       \a (b :: AvsLicence) -> compare a b == compare (toPersistValue a) (toPersistValue b)
     it "assigns AvsLicence fixed SQL values" . example $ do    -- ensure that DB encoding does not change unnoticed
@@ -135,8 +135,8 @@ spec = do
       Aeson.toJSON AvsLicenceVorfeld  `shouldBe` Aeson.Number 1
       Aeson.toJSON AvsLicenceRollfeld `shouldBe` Aeson.Number 2
 
-  describe "Ord AvsPersonLicence" $ do 
-    it "proritises avsLicenceRampLicence" . property $ 
+  describe "Ord AvsPersonLicence" $ do
+    it "proritises avsLicenceRampLicence" . property $
       \p0 p1@AvsPersonLicence{avsLicenceRampLicence=v1} ->
         let p2@AvsPersonLicence{avsLicenceRampLicence=v2} = p0 in
         (v1 /= v2) ==> compare p1 p2 == compare v1 v2