Implement assignSubmissions

package.yaml

@@ -80,6 +80,7 @@ dependencies:
 - uuid
 - exceptions
 - lens
+- MonadRandom
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.
@@ -92,6 +93,7 @@ library:
       - -Wall
       - -fwarn-tabs
       - -O0
+      - -ddump-splices
       cpp-options: -DDEVELOPMENT
     else:
       ghc-options:

src/Handler/Utils/Submission.hs

@@ -15,19 +15,20 @@ module Handler.Utils.Submission
   , sinkSubmission
   ) where
 
-import Import -- hiding ()
+import Import hiding ((.=))
 
 import Control.Lens
 import Control.Lens.Extras (is)
 import Utils.Lens
 
 import Control.Monad.State hiding (forM_)
+import qualified Control.Monad.Random as Rand
 
 import Data.Maybe
 
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Map (Map)
+import Data.Map (Map, (!?))
 import qualified Data.Map as Map
 
 
@@ -41,10 +42,17 @@ import qualified Database.Esqueleto as E
 import qualified Data.Conduit.List as Conduit
 
 
+data AssignSubmissionException = NoCorrectorsByProportion
+  deriving (Typeable, Show)
+
+instance Exception AssignSubmissionException
+
 assignSubmissions :: SheetId -> YesodDB UniWorX ()
 assignSubmissions sid = do
     correctors <- selectList [SheetCorrectorSheet ==. sid] []
-    let (corrsGroup, normalize -> corrsProp) = partition (is _ByTutorial . sheetCorrectorLoad . entityVal) correctors
+    let (corrsGroup, corrsProp) = partition (is _ByTutorial . sheetCorrectorLoad . entityVal) correctors
+        countsToLoad' :: UserId -> Bool
+        countsToLoad' uid = fromMaybe (error "Called `countsToLoad'` on entity not element of `corrsGroup`") $ listToMaybe [sheetCorrectorLoad | Entity _ SheetCorrector{..} <- corrsGroup, sheetCorrectorUser == uid] >>= preview _ByTutorial
     subs <- E.select . E.from $ \(submission `E.LeftOuterJoin` user) -> do
         let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do
               -- Uncomment next line for equal chance between tutors, irrespective of the number of students per tutor per submission group
@@ -56,17 +64,33 @@ assignSubmissions sid = do
         E.on $ user E.?. UserId `E.in_` E.justList tutors
         E.where_ $  submission E.^. SubmissionSheet E.==. E.val sid
         E.orderBy [E.rand] -- randomize for fair tutor distribution
-        return (submission E.^. SubmissionId, user E.?. UserId) -- , listToMaybe tutors)
-    let subTutor :: Map SubmissionId (Maybe UserId)
-        subTutor = Map.fromListWith (<|>) $ map (bimap E.unValue E.unValue) subs
-    -- TODO: Continue here --
-    return ()
-  where
-    _Load :: Traversal' (Entity SheetCorrector) Rational
-    _Load = _entityVal . _sheetCorrectorLoad . _ByProportion
+        return (submission E.^. SubmissionId, user) -- , listToMaybe tutors)
 
-    normalize :: [Entity SheetCorrector] -> [Entity SheetCorrector]
-    normalize corrsProp = corrsProp & each . _Load //~ sumOf (each . _Load) corrsProp
+    queue <- liftIO . Rand.evalRandIO . sequence . repeat $ Rand.weightedMay [ (sheetCorrectorUser, load sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp]
+
+    let subTutor' :: Map SubmissionId (Maybe UserId)
+        subTutor' = Map.fromListWith (<|>) $ map (over (_2.traverse) entityKey . over _1 E.unValue) subs
+
+    subTutor <- fmap fst . flip execStateT (Map.empty, queue) . forM_ (Map.toList subTutor') $ \case
+      (smid, Just tutid) -> do
+        _1 %= Map.insert smid tutid
+        when (countsToLoad' tutid) $
+          _2 %= delFirst (Just tutid)
+      (smid, Nothing) -> do
+        (q:qs) <- use _2
+        _2 .= qs
+        case q of
+          Just q  -> _1 %= Map.insert smid q
+          Nothing -> throwM NoCorrectorsByProportion
+
+    forM_ (Map.toList subTutor) $ \(smid, tutid) -> update smid [SubmissionRatingBy =. Just tutid]
+        
+    return ()
+    where
+      delFirst _ [] = []
+      delFirst x (y:ys)
+        | x == y = ys
+        | otherwise = y:delFirst x ys