From 72b2b6876b70b5feb48fcfc8198b0989365ceab1 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 7 Oct 2024 12:58:22 +0200 Subject: [PATCH] fix(test): add arbitrart instances and adjust argument changes to tests --- test/Handler/Utils/SubmissionSpec.hs | 16 ++++++++-------- test/Model/TypesSpec.hs | 2 +- test/ModelSpec.hs | 5 +++-- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/test/Handler/Utils/SubmissionSpec.hs b/test/Handler/Utils/SubmissionSpec.hs index ed50724ba..402e9fc9b 100644 --- a/test/Handler/Utils/SubmissionSpec.hs +++ b/test/Handler/Utils/SubmissionSpec.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -49,7 +49,7 @@ makeUsers (fromIntegral -> n) = do users <- forM users' $ \u -> do i <- atomically $ readTVar userNumber <* modifyTVar userNumber succ let baseid = "user." <> tshow i - u' = u { userIdent = CI.mk baseid + u' = u { userIdent = CI.mk baseid , userEmail = CI.mk $ baseid <> "@example.com" , userLdapPrimaryKey = Just $ baseid <> ".ldap" } @@ -82,7 +82,7 @@ distributionExample mkParameters setupHook cont = do participants' <- liftIO $ take (fromIntegral subsN') <$> shuffleM participants let loads' = loads ++ replicate (fromIntegral $ correctorsN - genericLength loads) Nothing - + submissions <- forM participants' $ \(Entity uid _) -> do sub@(Entity subId _) <- insertEntity $ Submission sid @@ -102,7 +102,7 @@ distributionExample mkParameters setupHook cont = do mapM_ (\(n, (subs, corrs)) -> setupHook n subs corrs) . zip [1..] $ map snd situations - -- situations' <- + -- situations' <- forM situations $ \(sid, (submissions, sheetCorrectors)) -> (sid, ) <$> do submissions' <- mapM (fmap fromJust . getEntity . entityKey) submissions sheetCorrectors' <- mapM (fmap fromJust . getEntity . entityKey) sheetCorrectors @@ -126,7 +126,7 @@ distributionExample mkParameters setupHook cont = do let key = find (\ (Entity _ (SheetCorrector uid _ _ _)) -> Just uid == submissionRatingBy) $ concatMap (\(_, (_, corrs)) -> corrs) situations sheet = getFirst . foldMap (\(n, (sid, _)) -> First $ guardOn (sid == submissionSheet) n) $ zip [1..] situations return (entityVal <$> key, Set.singleton (subId, sheet)) - + spec :: Spec spec = withApp . describe "Submission distribution" $ do @@ -196,16 +196,16 @@ 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) + return $ TutorialParticipant E.<# E.val tutId E.<&> (submissionUser E.^. SubmissionUserUser) E.<&> E.nothing ) (\result -> do let countResult = Map.map Set.size result countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> (fromSqlKey sheetCorrectorUser, byProportion sheetCorrectorLoad)) countResult countResult' `shouldNotSatisfy` Map.member Nothing countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> fromIntegral subsSet == 50 * prop) . Map.toList - + -- -- Does not currently work, because `User`s are reused within `distributionExample`, so submissions end up having more associated course-tutors, because the same user might be a member of a tutorial created for another submission - -- + -- -- let subs = fold tutSubIds' -- forM_ subs $ \subId -> do -- let tutors = Map.keysSet $ Map.filter (Set.member subId) tutSubIds' diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 57ae987aa..078a928ad 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -318,7 +318,7 @@ instance Arbitrary CsvOptions where arbitrary = CsvOptions <$> arbitrary <*> arbitrary - <*> suchThat arbitrary (maybe True $ not . elem (Char.chr 0)) + <*> suchThat arbitrary (maybe True $ notElem (Char.chr 0)) shrink = genericShrink instance Arbitrary CsvPreset where diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index 28a3ecc4d..5d9e3a969 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -41,6 +41,8 @@ import System.IO.Unsafe (unsafePerformIO) import Data.Universe +deriving newtype instance Arbitrary a => Arbitrary (JSONB a) + instance Arbitrary EmailAddress where arbitrary = do local <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\l -> isEmail l (CBS.pack "example.com")) @@ -86,7 +88,6 @@ instance Arbitrary Tutorial where <*> (fmap getPositive <$> arbitrary) <*> arbitrary <*> arbitrary - <*> arbitrary <*> (fmap (CI.mk . pack . getPrintableString) <$> arbitrary) <*> arbitrary <*> arbitrary