assignment of submissions halfway done

models

@@ -115,7 +115,7 @@ SheetEdit
     sheet           SheetId
 SheetCorrector
     user            UserId
-    sheet           CourseId
+    sheet           SheetId
     load            Load
 SheetFile
     sheet           SheetId

package.yaml

@@ -79,6 +79,7 @@ dependencies:
 - parsec
 - uuid
 - exceptions
+- lens
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Handler/Utils/Submission.hs

@@ -15,12 +15,21 @@ module Handler.Utils.Submission
   , sinkSubmission
   ) where
 
-import Import
+import Import -- hiding ()
+
+import Control.Lens
+import Control.Lens.Extras (is)
+import Utils.Lens
 
 import Control.Monad.State hiding (forM_)
 
+import Data.Maybe
+
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Data.Map (Map)
+import qualified Data.Map as Map
+
 
 import Data.Monoid (Monoid, Any(..))
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
@@ -32,6 +41,35 @@ import qualified Database.Esqueleto as E
 import qualified Data.Conduit.List as Conduit
 
 
+assignSubmissions :: SheetId -> YesodDB UniWorX ()
+assignSubmissions sid = do
+    correctors <- selectList [SheetCorrectorSheet ==. sid] []
+    let (corrsGroup, normalize -> corrsProp) = partition (is _ByTutorial . sheetCorrectorLoad . entityVal) correctors
+    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
+              -- E.distinctOn [E.don $ tutorial E.^. TutorialTutor] $ do
+                E.on (tutorial       E.^. TutorialId         E.==. tutorialUser E.^. TutorialUserTutorial)
+                E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser)
+                E.where_ (tutorial   E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsGroup))
+                return $ tutorial E.^. TutorialTutor
+        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
+
+    normalize :: [Entity SheetCorrector] -> [Entity SheetCorrector]
+    normalize corrsProp = corrsProp & each . _Load //~ sumOf (each . _Load) corrsProp
+
+
+
 data SubmissionSinkState = SubmissionSinkState
   { sinkSeenRating :: Any
   , sinkSubmissionTouched :: Any

src/Model/Types.hs

@@ -77,10 +77,16 @@ data ExamStatus = Attended | NoShow | Voided
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 derivePersistField "ExamStatus"
 
-data Load = ByTutorial | ByProportion Rational
+data Load = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational }
   deriving (Show, Read, Eq)
 derivePersistField "Load"
 
+{- Use (is _ByTutorial) instead of this unneeded definition:
+  isByTutorial :: Load -> Bool
+  isByTutorial (ByTutorial {}) = True
+  isByTutorial _               = False
+-}
+
 data Season = Summer | Winter
   deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
 

src/Utils/Lens.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+module Utils.Lens where
+
+import Import.NoFoundation
+import Control.Lens
+
+makeClassy_ ''Entity
+
+makeClassy_ ''SheetCorrector
+
+makeClassyPrisms ''Load