fix(test): fix test problem and add tests for UserEyeExam and UserDrivingPermit

src/Model/Types/User.hs

@@ -38,6 +38,9 @@ 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
@@ -52,9 +55,10 @@ 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
-
-

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, persistFieldLaws ]
+    lawsCheckHspec (Proxy @UserEyeExam)
+      [ eqLaws, ordLaws, showLaws, boundedEnumLaws, finiteLaws, 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 
+  describe "Ord AvsPersonLicence" $ do
-    it "proritises avsLicenceRampLicence" . property $ 
+    it "proritises avsLicenceRampLicence" . property $
       \p0 p1@AvsPersonLicence{avsLicenceRampLicence=v1} ->
         let p2@AvsPersonLicence{avsLicenceRampLicence=v2} = p0 in
         (v1 /= v2) ==> compare p1 p2 == compare v1 v2