Additional testing

package.yaml

@@ -243,6 +243,7 @@ tests:
       - uniworx
       - hspec >=2.0.0
       - QuickCheck
+      - HUnit
       - yesod-test
       - conduit-extra
       - quickcheck-classes

src/Handler/Utils/Submission.hs

@@ -188,7 +188,7 @@ assignSubmissions sid restriction = do
     -- 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
+    (newSubmissionData, ()) <- (\act -> execRWST act oldSubmissionData targetSubmissionData) . forM_ (zip [1..] targetSubmissions') $ \(i, subId) -> do
       tutors <- gets $ view _2 . (! subId) -- :: Map UserId (Sum Natural)
       let acceptableCorrectors
             | correctorsByTut <- Map.filter (is _Just . view _byTutorial) $ sheetCorrectors `Map.restrictKeys` Map.keysSet tutors
@@ -205,9 +205,9 @@ assignSubmissions sid restriction = do
             & maximumsBy (deficits !)
             & maximumsBy (tutors !?)
 
-        $logDebugS "assignSubmissions" [st|Tutors for #{tshow subId}: #{tshow tutors}|]
+        $logDebugS "assignSubmissions" [st|#{tshow i} Tutors for #{tshow subId}: #{tshow tutors}|]
-        $logDebugS "assignSubmissions" [st|Current (#{tshow subId}) relevant deficits: #{tshow deficits}|]
+        $logDebugS "assignSubmissions" [st|#{tshow i} Current (#{tshow subId}) relevant deficits: #{tshow deficits}|]
-        $logDebugS "assignSubmissions" [st|Assigning #{tshow subId} to one of #{tshow bestCorrectors}|]
+        $logDebugS "assignSubmissions" [st|#{tshow i} Assigning #{tshow subId} to one of #{tshow bestCorrectors}|]
 
         ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors)
 

test/Handler/Utils/SubmissionSpec.hs

@@ -3,11 +3,13 @@ module Handler.Utils.SubmissionSpec where
 import qualified Yesod
 
 import TestImport
+-- import qualified Test.HUnit.Base as HUnit
 
 import Handler.Utils.Submission
 import ModelSpec ()
 
 import qualified Data.Set as Set
+import Data.Map ((!?))
 import qualified Data.Map as Map
 
 import Data.List (genericLength)
@@ -19,10 +21,12 @@ import System.IO.Unsafe
 import System.Random.Shuffle
 import Control.Monad.Random.Class
 
-import Database.Persist.Sql (fromSqlKey)
+import Database.Persist.Sql (toSqlKey, fromSqlKey)
 
 import qualified Database.Esqueleto as E
 
+-- import Data.Maybe (fromJust)
+
 
 userNumber :: TVar Natural
 userNumber = unsafePerformIO $ newTVarIO 1
@@ -135,10 +139,27 @@ spec = withApp . describe "Submission distribution" $ do
           countResult `shouldNotSatisfy` Map.member Nothing
           countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList
       )
+  it "follows non-constant cumulative distribution over multiple sheets" $ do
+    let ns = replicate 4 100
+        loads = do
+          (onesBefore, onesAfter) <- zip [0,2..6] [6,4..0]
+          return $ replicate onesBefore (Just $ Load Nothing 1)
+                ++ replicate 2          (Just $ Load Nothing 2)
+                ++ replicate onesAfter  (Just $ Load Nothing 1)
+    distributionExample
+      (return $ zip ns loads)
+      (\_ _ -> return ())
+      (\result -> do
+          let countResult = Map.map Set.size result
+              countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> fromSqlKey sheetCorrectorUser) countResult
+          countResult `shouldNotSatisfy` Map.member Nothing
+          countResult' `shouldSatisfy` all (\(Just _, subsSet) -> subsSet == 50) . 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)
+        loads = replicate 6 (Just $ Load (Just True) 1) ++ replicate 2 (Just $ Load (Just True) 2)
+    tutSubIds <- liftIO $ newTVarIO Map.empty
     distributionExample
       (return [ (n, loads) | n <- ns' ])
       (\subs corrs -> do
@@ -146,6 +167,7 @@ spec = withApp . describe "Submission distribution" $ do
           subs' <- liftIO $ shuffleM subs
           forM_ (take tutSubmissions subs') $ \(Entity subId Submission{..}) -> do
             Entity _ SheetCorrector{..} <- liftIO $ uniform corrs
+            atomically . modifyTVar tutSubIds . Map.insertWith mappend sheetCorrectorUser $ Set.singleton subId
             Sheet{..} <- getJust submissionSheet
             tut <- liftIO $ generate arbitrary <&> \c -> c { tutorialName = CI.mk $ "Tut for " <> tshow (fromSqlKey subId), tutorialCourse = sheetCourse }
             tutId <- insert tut
@@ -157,6 +179,17 @@ spec = withApp . describe "Submission distribution" $ do
       (\result -> do
           let countResult = Map.map Set.size result
               countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> (fromSqlKey sheetCorrectorUser, byProportion sheetCorrectorLoad)) countResult
-          countResult `shouldNotSatisfy` Map.member Nothing
+          tutSubIds' <- liftIO $ readTVarIO tutSubIds
-          countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList
+
+          countResult' `shouldNotSatisfy` Map.member Nothing
+          countResult' `shouldSatisfy` all (\(Just (corr, prop), subsSet) -> fromIntegral subsSet <= max (50 * prop) (maybe 0 (fromIntegral . Set.size) $ tutSubIds' !? toSqlKey corr)) . 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'
+          --       assignedTo = Set.map (sheetCorrectorUser . fromJust) . Map.keysSet $ Map.filter (Set.member subId) result
+          --   HUnit.assertEqual ("Submission " <> show (fromSqlKey subId) <> " assigned to multiple correctors") 1 $ Set.size assignedTo
+          --   HUnit.assertEqual ("Submission " <> show (fromSqlKey subId) <> " assigned to non-tutors (" <> show (Set.map fromSqlKey tutors) <> ")") Set.empty (Set.map fromSqlKey $ assignedTo `Set.difference` tutors)
       )