From a9fe7487a63eb321f1039f39cfb1a7daa028c519 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 7 Jul 2021 11:33:14 +0200 Subject: [PATCH] chore: fix tests --- src/Handler/Exam/Edit.hs | 2 +- src/Handler/Exam/Form.hs | 2 +- src/Handler/Sheet/Form.hs | 2 +- src/Model/Types/School.hs | 2 +- test/Model/TypesSpec.hs | 5 +++++ test/ModelSpec.hs | 9 ++++++++- 6 files changed, 17 insertions(+), 5 deletions(-) diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index cc00bbc35..774913d5f 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -51,7 +51,7 @@ postEEditR tid ssh csh examn = do | Just (Entity previousStatementId _) <- mPreviousStatement -> update previousStatementId [ AuthorshipStatementDefinitionContent =. newStatementContent ] >> return (Just previousStatementId) | otherwise - -> fmap Just $ insert AuthorshipStatementDefinition { authorshipStatementDefinitionContent = newStatementContent } + -> Just <$> insert AuthorshipStatementDefinition { authorshipStatementDefinitionContent = newStatementContent } insertRes <- myReplaceUnique eId Exam { examCourse = cid diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index fc1b3f020..40796dad0 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -151,7 +151,7 @@ examForm (Entity _ Course{..}) template csrf = hoist liftHandler $ do reqContentField :: (FieldSettings UniWorX -> FieldSettings UniWorX) -> AForm Handler StoredMarkup reqContentField ttip = areq htmlField (fslI MsgExamAuthorshipStatementContent & ttip) - ( (join $ efAuthorshipStatement <$> template) + ( (efAuthorshipStatement =<< template) <|> (authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement) ) forcedContentField = aforced htmlField diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs index 7de3e713e..7c7dd5b00 100644 --- a/src/Handler/Sheet/Form.hs +++ b/src/Handler/Sheet/Form.hs @@ -111,7 +111,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS reqContentField :: (FieldSettings UniWorX -> FieldSettings UniWorX) -> AForm Handler StoredMarkup reqContentField ttip = areq htmlField (fslI MsgSheetAuthorshipStatementContent & ttip) - ( (join $ sfAuthorshipStatement <$> template) + ( (sfAuthorshipStatement =<< template) <|> (authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement) ) forcedContentField = aforced htmlField diff --git a/src/Model/Types/School.hs b/src/Model/Types/School.hs index bb739f563..fe9b43e5b 100644 --- a/src/Model/Types/School.hs +++ b/src/Model/Types/School.hs @@ -25,7 +25,7 @@ data SchoolAuthorshipStatementMode deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) deriving anyclass (Universe, Finite, NFData) -nullaryPathPiece ''SchoolAuthorshipStatementMode $ camelToPathPiece' 4 +finitePathPiece ''SchoolAuthorshipStatementMode [ "no-statement", "optional", "required" ] pathPieceJSON ''SchoolAuthorshipStatementMode pathPieceJSONKey ''SchoolAuthorshipStatementMode derivePersistFieldPathPiece ''SchoolAuthorshipStatementMode diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index e7b88713f..251b9adf3 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -340,6 +340,9 @@ instance Arbitrary UploadNonce where arbitrary = pure $ unsafePerformIO newUploadNonce +instance Arbitrary SchoolAuthorshipStatementMode where + arbitrary = genericArbitrary + spec :: Spec spec = do @@ -448,6 +451,8 @@ spec = do [ eqLaws, ordLaws, showLaws, showReadLaws, pathPieceLaws, jsonLaws, persistFieldLaws, binaryLaws ] lawsCheckHspec (Proxy @UploadNonce) [ eqLaws, ordLaws, showLaws, showReadLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws ] + lawsCheckHspec (Proxy @SchoolAuthorshipStatementMode) + [ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws, binaryLaws ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index b0adbaaec..f99b1298b 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -68,8 +68,9 @@ instance Arbitrary Sheet where <*> arbitrary <*> arbitrary <*> arbitrary - <*> return Nothing + <*> pure Nothing <*> arbitrary + <*> pure Nothing shrink = genericShrink instance Arbitrary Tutorial where @@ -164,6 +165,12 @@ instance Arbitrary School where schoolExamRequireModeForRegistration <- arbitrary schoolExamDiscouragedModes <- arbitrary schoolExamCloseMode <- arbitrary + schoolSheetAuthorshipStatementMode <- arbitrary + let schoolSheetAuthorshipStatementDefinition = Nothing + schoolSheetAuthorshipStatementAllowOther <- arbitrary + schoolSheetExamAuthorshipStatementMode <- arbitrary + let schoolSheetExamAuthorshipStatementDefinition = Nothing + schoolSheetExamAuthorshipStatementAllowOther <- arbitrary return School{..} instance Arbitrary Term where