diff --git a/src/Model/Types/User.hs b/src/Model/Types/User.hs index d2143636c..b7fec9225 100644 --- a/src/Model/Types/User.hs +++ b/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 - - diff --git a/test/Handler/Utils/SubmissionSpec.hs b/test/Handler/Utils/SubmissionSpec.hs index 402e9fc9b..f1ef2ba5e 100644 --- a/test/Handler/Utils/SubmissionSpec.hs +++ b/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 diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 078a928ad..0b271c547 100644 --- a/test/Model/TypesSpec.hs +++ b/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 diff --git a/test/Utils/TypesSpec.hs b/test/Utils/TypesSpec.hs index b3b8aaea6..e54aaea84 100644 --- a/test/Utils/TypesSpec.hs +++ b/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