Additional testing

models/tutorials

@@ -11,6 +11,7 @@ Tutorial json
     deregisterUntil UTCTime Maybe
     lastChanged     UTCTime default=now()
     UniqueTutorial course name
+    deriving Generic
 Tutor
     tutorial    TutorialId
     user        UserId

src/Handler/Utils/Submission.hs

@@ -94,10 +94,12 @@ assignSubmissions sid restriction = do
     unless (Map.member sid correctors) $
       throwM NoCorrectors
 
-    submissionDataRaw <- E.select . E.from $ \((sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) `E.LeftOuterJoin` (tutorialUser `E.InnerJoin` tutor)) -> do
+    submissionDataRaw <- E.select . E.from $ \((sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) `E.LeftOuterJoin` (tutorial `E.InnerJoin` tutorialUser `E.InnerJoin` tutor)) -> do
-      E.on $ tutor E.?. TutorTutorial E.==. tutorialUser E.?. TutorialParticipantTutorial
+      E.on $ tutor E.?. TutorTutorial E.==. tutorial E.?. TutorialId
+      E.on $ tutorialUser E.?. TutorialParticipantTutorial E.==. tutorial E.?. TutorialId
       E.on $ tutorialUser E.?. TutorialParticipantUser E.==. E.just (submissionUser E.^. SubmissionUserUser)
        E.&&. tutor E.?. TutorUser `E.in_` E.justList (E.valList $ foldMap Map.keys correctors)
+       E.&&. tutorial E.?. TutorialCourse E.==. E.just (E.val sheetCourse)
       E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
       E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
 
@@ -114,12 +116,15 @@ assignSubmissions sid restriction = do
                           )
       submissionData = Map.fromListWith merge $ map process submissionDataRaw
         where
-          process (E.Value sheetId, Entity subId Submission{..}, E.Value mTutId) = (subId, (submissionRatingBy, maybe Map.empty (flip Map.singleton $ Sum 1) mTutId, sheetId))
+          process (E.Value sheetId, Entity subId Submission{..}, E.Value mTutId) = (subId, (submissionRatingBy, maybe Map.empty (flip Map.singleton $ Sum 1) $ assertM isCorrectorByTutorial mTutId, sheetId))
           merge (corrA, tutorsA, sheetA) (corrB, tutorsB, sheetB)
             | corrA /= corrB   = error "Same submission seen with different correctors"
             | sheetA /= sheetB = error "Same submission seen with different sheets"
             | otherwise        = (corrA, Map.unionWith mappend tutorsA tutorsB, sheetA)
 
+          -- Not done in esqueleto, since inspection of `Load`-Values is difficult
+          isCorrectorByTutorial = maybe False (\Load{..} -> is _Just byTutorial) . flip Map.lookup sheetCorrectors
+
       targetSubmissions = Set.fromList $ do
         (E.Value sheetId, Entity subId Submission{..}, _) <- submissionDataRaw
         guard $ sheetId == sid
@@ -143,7 +148,7 @@ assignSubmissions sid restriction = do
       withSubmissionData f = f <$> (mappend <$> ask <*> State.get)
       
       -- | How many additional submission should the given corrector be assigned, if possible?
-      calculateDeficit :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Integer
+      calculateDeficit :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Rational
       calculateDeficit corrector submissionState = getSum $ foldMap Sum deficitBySheet
         where
           sheetSizes :: Map SheetId Integer
@@ -152,10 +157,10 @@ assignSubmissions sid restriction = do
             (_, (Just _, _, sheetId)) <- Map.toList submissionState
             return (sheetId, Sum 1)
 
-          deficitBySheet :: Map SheetId Integer
+          deficitBySheet :: Map SheetId Rational
           -- ^ Deficite of @corrector@ per sheet
           deficitBySheet = flip Map.mapMaybeWithKey sheetSizes $ \sheetId sheetSize -> do
-            let assigned :: Integer
+            let assigned :: Rational
                 assigned = fromIntegral . Map.size $ Map.filter (\(mCorr, _, sheetId') -> mCorr == Just corrector && sheetId == sheetId') submissionState
                 proportionSum :: Rational
                 proportionSum = getSum . foldMap corrProportion . fromMaybe Map.empty $ correctors !? sheetId
@@ -172,13 +177,16 @@ assignSubmissions sid restriction = do
                         return . negate . fromIntegral . Map.size $ Map.filter (\(mCorr, tutors, sheetId') -> mCorr == Just corrector && sheetId == sheetId' && Map.member corrector tutors) submissionState
                     , fromMaybe 0 $ do
                         guard $ corrState /= CorrectorExcused
-                        return . negate . floor $ (byProportion / proportionSum) * fromIntegral sheetSize
+                        return . negate $ (byProportion / proportionSum) * fromIntegral sheetSize
                     ] 
                   | otherwise
                   = assigned
             return $ negate extra
 
-    targetSubmissions' <- liftIO . Rand.shuffleM $ Set.toList targetSubmissions
+    -- Sort target submissions by those that have tutors first and otherwise random
+    --
+    -- Deficit produced by restriction to tutors can thus be fixed by later submissions
+    targetSubmissions' <- liftIO . unstableSortBy (comparing $ \subId -> Map.null . view _2 $ submissionData ! subId) $ Set.toList targetSubmissions
 
     (newSubmissionData, ()) <- (\act -> execRWST act oldSubmissionData targetSubmissionData) . forM_ targetSubmissions' $ \subId -> do
       tutors <- gets $ view _2 . (! subId) -- :: Map UserId (Sum Natural)
@@ -197,6 +205,10 @@ assignSubmissions sid restriction = do
             & maximumsBy (deficits !)
             & maximumsBy (tutors !?)
 
+        $logDebugS "assignSubmissions" [st|Tutors for #{tshow subId}: #{tshow tutors}|]
+        $logDebugS "assignSubmissions" [st|Current (#{tshow subId}) relevant deficits: #{tshow deficits}|]
+        $logDebugS "assignSubmissions" [st|Assigning #{tshow subId} to one of #{tshow bestCorrectors}|]
+
         ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors)
 
     now <- liftIO getCurrentTime
@@ -212,6 +224,9 @@ assignSubmissions sid restriction = do
     maximumsBy :: (Ord a, Ord b) => (a -> b) -> Set a -> Set a
     maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs
 
+    unstableSortBy :: MonadRandom m => (a -> a -> Ordering) -> [a] -> m [a]
+    unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp
+
 
 submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
 submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery

test/Handler/Utils/SubmissionSpec.hs

@@ -21,6 +21,8 @@ import Control.Monad.Random.Class
 
 import Database.Persist.Sql (fromSqlKey)
 
+import qualified Database.Esqueleto as E
+
 
 userNumber :: TVar Natural
 userNumber = unsafePerformIO $ newTVarIO 1
@@ -57,8 +59,8 @@ distributionExample mkParameters setupHook cont = do
     participants <- makeUsers subsN
     correctors <- makeUsers correctorsN
 
-    situations <- forM steps $ \(subsN', loads) -> do
+    situations <- forM (zip [1..] steps) $ \(i, (subsN', loads)) -> do
-      sheet <- liftIO $ generate arbitrary <&> \s -> s { sheetCourse = cid }
+      sheet <- liftIO $ generate arbitrary <&> \s -> s { sheetName = CI.mk $ "Sheet " <> tshow (i :: Integer), sheetCourse = cid }
       sid <- insert sheet
 
       participants' <- liftIO $ take (fromIntegral subsN') <$> shuffleM participants
@@ -133,3 +135,28 @@ spec = withApp . describe "Submission distribution" $ do
           countResult `shouldNotSatisfy` Map.member Nothing
           countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList
       )
+  it "handles tutorials with proportion" $ do
+    ns <- liftIO . replicateM 5 . fmap fromInteger $ getRandomR (0, 100)
+    let ns' = ns ++ [500 - sum ns]
+        loads = replicate 6 (Just $ Load Nothing 1) ++ replicate 2 (Just $ Load Nothing 2)
+    distributionExample
+      (return [ (n, loads) | n <- ns' ])
+      (\subs corrs -> do
+          tutSubmissions <- liftIO $ getRandomR (1,500)
+          subs' <- liftIO $ shuffleM subs
+          forM_ (take tutSubmissions subs') $ \(Entity subId Submission{..}) -> do
+            Entity _ SheetCorrector{..} <- liftIO $ uniform corrs
+            Sheet{..} <- getJust submissionSheet
+            tut <- liftIO $ generate arbitrary <&> \c -> c { tutorialName = CI.mk $ "Tut for " <> tshow (fromSqlKey subId), tutorialCourse = sheetCourse }
+            tutId <- insert tut
+            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)
+      )
+      (\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) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList
+      )

test/Model/TypesSpec.hs

@@ -21,6 +21,8 @@ import Text.Blaze.Renderer.Text
 
 import qualified Data.Set as Set
 
+import Time.Types (WeekDay(..))
+
 
 instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where
   arbitrary = arbitrary `suchThatMap` fromNullable
@@ -193,6 +195,21 @@ instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Arbitrary (Key r
 instance Arbitrary Html where
   arbitrary = (preEscapedToHtml :: String -> Html) . getPrintableString <$> arbitrary
   shrink = map preEscapedToHtml . shrink . renderMarkup
+
+instance Arbitrary WeekDay where
+  arbitrary = oneof $ map pure [minBound..maxBound]
+
+instance Arbitrary OccurenceSchedule where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary OccurenceException where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary Occurences where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
   
 
 spec :: Spec

test/ModelSpec.hs

@@ -54,6 +54,21 @@ instance Arbitrary Sheet where
     <*> arbitrary
   shrink = genericShrink
 
+instance Arbitrary Tutorial where
+  arbitrary = Tutorial
+    <$> (CI.mk . pack . getPrintableString <$> arbitrary)
+    <*> arbitrary
+    <*> (CI.mk . pack . getPrintableString <$> arbitrary)
+    <*> (fmap getPositive <$> arbitrary)
+    <*> (pack . getPrintableString <$> arbitrary)
+    <*> arbitrary
+    <*> (fmap (CI.mk . pack . getPrintableString) <$> arbitrary)
+    <*> arbitrary
+    <*> arbitrary
+    <*> arbitrary
+    <*> arbitrary
+  shrink = genericShrink
+
 instance Arbitrary User where
   arbitrary = do
     userIdent <- CI.mk . pack <$> oneof