From 071e8c2de126d1c3c3c2c37ad194a2f3fb30f242 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Thu, 26 Apr 2018 14:16:22 +0200
Subject: [PATCH] assignment of submissions halfway done

---
 models                          |  2 +-
 package.yaml                    |  1 +
 src/Handler/Utils/Submission.hs | 42 +++++++++++++++++++++++++++++++--
 src/Model/Types.hs              |  8 ++++++-
 src/Utils/Lens.hs               | 15 ++++++++++++
 5 files changed, 64 insertions(+), 4 deletions(-)
 create mode 100644 src/Utils/Lens.hs

diff --git a/models b/models
index ae1518f40..4cc88aaf2 100644
--- a/models
+++ b/models
@@ -115,7 +115,7 @@ SheetEdit
     sheet           SheetId
 SheetCorrector
     user            UserId
-    sheet           CourseId
+    sheet           SheetId
     load            Load
 SheetFile
     sheet           SheetId
diff --git a/package.yaml b/package.yaml
index fb495c5a8..8669cb6ab 100644
--- a/package.yaml
+++ b/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.
diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index 9b71290a3..86247d39a 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@@ -15,13 +15,22 @@ 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
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 449d947d7..9be9a1c2b 100644
--- a/src/Model/Types.hs
+++ b/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)
 
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
new file mode 100644
index 000000000..c2d8371b8
--- /dev/null
+++ b/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