Merge branch 'release/1.1.1.0'

obcode · obcode · commit cc7551621ed6 · 2019-07-18T19:35:04.000+02:00
diff --git a/.travis.yml b/.travis.yml
@@ -50,24 +50,24 @@ script:
   - hlint .
   - stack --no-terminal test
 
-jobs:
-  include:
-    - stage: Deploy Haddock
-      os: linux
-      script:
-        - stack --no-terminal test --haddock --no-haddock-deps
-        - mkdir docs
-        - ls
-        - stack path --local-doc-root
-        - ls `stack path --local-doc-root`
-        - mv `stack path --local-doc-root` docs/haddock
-      deploy:
-        provider: pages
-        skip_cleanup: true
-        github_token: $GITHUB_TOKEN
-        on:
-          all_branches: true
-        local_dir: docs/haddock
+# jobs:
+#   include:
+#     - stage: Deploy Haddock
+#       os: linux
+#       script:
+#         - stack --no-terminal test --haddock --no-haddock-deps
+#         - mkdir docs
+#         - ls
+#         - stack path --local-doc-root
+#         - ls `stack path --local-doc-root`
+#         - mv `stack path --local-doc-root` docs/haddock
+#       deploy:
+#         provider: pages
+#         skip_cleanup: true
+#         github_token: $GITHUB_TOKEN
+#         on:
+#           all_branches: true
+#         local_dir: docs/haddock
 
 notifications:
   email:
diff --git a/plexams-cli/package.yaml b/plexams-cli/package.yaml
@@ -1,5 +1,5 @@
 name: plexams-cli
-version: "1.1.0.1"
+version: "1.1.1.0"
 synopsis: Command line interface for planning exams
 description: See README at <https://github.com/obcode/plexams#readme>
 license: BSD3
diff --git a/plexams-core/package.yaml b/plexams-core/package.yaml
@@ -1,5 +1,5 @@
 name: plexams-core
-version: "1.1.0.1"
+version: "1.1.1.0"
 synopsis: Core modules for planning exams
 description: See README at <https://github.com/obcode/plexams#readme>
 license: BSD3
diff --git a/plexams-datamgmt/package.yaml b/plexams-datamgmt/package.yaml
@@ -1,5 +1,5 @@
 name: plexams-datamgmt
-version: "1.1.0.1"
+version: "1.1.1.0"
 synopsis: Data Management modules for planning exams
 description: See README at <https://github.com/obcode/plexams#readme>
 license: BSD3
diff --git a/plexams-generators/package.yaml b/plexams-generators/package.yaml
@@ -1,5 +1,5 @@
 name: plexams-generators
-version: "1.1.0.1"
+version: "1.1.1.0"
 synopsis: Generator modules for planning exams
 description: See README at <https://github.com/obcode/plexams#readme>
 license: BSD3
diff --git a/plexams-server/package.yaml b/plexams-server/package.yaml
@@ -1,5 +1,5 @@
 name: plexams-server
-version: "1.1.0.1"
+version: "1.1.1.0"
 synopsis: Server for planning exams
 description: See README at <https://github.com/obcode/plexams#readme>
 license: BSD3
diff --git a/plexams-validation/package.yaml b/plexams-validation/package.yaml
@@ -1,5 +1,5 @@
 name: plexams-validation
-version: "1.1.0.1"
+version: "1.1.1.0"
 synopsis: Validation modules for planning exams
 description: See README at <https://github.com/obcode/plexams#readme>
 license: BSD3
diff --git a/plexams-validation/src/Plexams/Validation/Invigilation.hs b/plexams-validation/src/Plexams/Validation/Invigilation.hs
@@ -49,7 +49,10 @@ validate plan = do
 validateAllSlotsHaveReserves
   :: Plan -> Writer [ValidationRecord] ValidationResult
 validateAllSlotsHaveReserves plan = do
-  tell [ValidationRecord Info "### Validating all slots have a reserve invigilator"]
+  tell
+    [ ValidationRecord Info
+                       "### Validating all slots have a reserve invigilator"
+    ]
   let slotsWithoutReserve =
         filter (isNothing . snd)
           $ map (second reserveInvigilator)
@@ -291,55 +294,93 @@ validateNotReserveOrInvigilatorIfExamInSlotOk
   -> Writer [ValidationRecord] ValidationResult
 validateNotReserveOrInvigilatorIfExamInSlotOk plan invigilatorID' invigilator'
   = do
-    let
-      ownReserveSlots =
-        map fst
-          $ filter ((== Just True) . snd)
-          $ map
-              (second
-                (fmap ((== invigilatorID') . invigilatorID) . reserveInvigilator
-                )
-              )
-          $ M.toList
-          $ slots plan
-      ownExamSlots =
-        mapMaybe slot
-          $ filter ((== invigilatorID') . personID . lecturer)
-          $ scheduledExams plan
-      ownInvigilatorSlots =
-        mapMaybe slot
-          $ filter
-              (\e ->
-                not
-                  (  personID (lecturer e)
-                  == invigilatorID'
-                  && length (rooms e)
-                  == 1
-                  )
-              )
-          $ filter
-              ( elem (Just invigilatorID')
-              . map (fmap invigilatorID . invigilator)
-              . rooms
-              )
-          $ scheduledExams plan
-      notReserveOrInvigilatorIfExamInSlotOk =
-        if null (ownExamSlots `intersect` ownReserveSlots)
-             &&
--- null (ownExamSlots `intersect` ownInvigilatorSlots) &&
-                null (ownReserveSlots `intersect` ownInvigilatorSlots)
-          then EverythingOk
-          else HardConstraintsBroken
-    unless (notReserveOrInvigilatorIfExamInSlotOk == EverythingOk) $ tell
-      [ ValidationRecord HardConstraintBroken
-        $        "- "
-        `append` invigilatorName invigilator'
-        `append` " has been scheduled as a reserve and invigilator"
-        `append` " during the same time, or reserve during own exams"
-        `append` " (exam, invig, reserve)"
-        `append` showt (ownExamSlots, ownInvigilatorSlots, ownReserveSlots)
-      ]
-    return notReserveOrInvigilatorIfExamInSlotOk
+    slotsOk <- forM (M.toList $ slots plan)
+                    (validateSlotForInvigilator invigilatorID' invigilator')
+    return $ validationResult slotsOk
+
+validateSlotForInvigilator
+  :: PersonID
+  -> Invigilator
+  -> ((DayIndex, SlotIndex), Slot)
+  -> Writer [ValidationRecord] ValidationResult
+validateSlotForInvigilator invigilatorID' invigilator' (slotIdxs, slot') = do
+  let
+    exams            = M.elems $ examsInSlot slot'
+    ownExams         = filter ((== invigilatorID') . personID . lecturer) exams
+    ownInvigilations = filter
+      ( (Just invigilatorID' `elem`)
+      . map (fmap invigilatorID . invigilator)
+      . rooms
+      )
+      exams
+  if null ownExams && null ownInvigilations
+    then return EverythingOk
+    else if (invigilatorID <$> reserveInvigilator slot') == Just invigilatorID'
+      then -- is reserve
+           do
+        tell
+          [ ValidationRecord HardConstraintBroken
+            $        "Problem in Slot "
+            `append` showt slotIdxs
+            `append` ": Reserveinvigilator "
+            `append` invigilatorName invigilator'
+            `append` if not $ null ownExams
+                       then " has own exam "
+                         `append` showt (map anCode ownExams)
+                       else " is invigilator "
+                         `append` showt (map anCode ownInvigilations)
+          ]
+        return HardConstraintsBroken
+      else -- not reserve
+           if null ownInvigilations
+        then return EverythingOk
+        else -- has invigilations
+          let
+            roomsOwnInvigilations =
+              groupWith roomID
+                $ filter
+                    ((Just invigilatorID' ==) . fmap invigilatorID . invigilator
+                    )
+                $ concatMap rooms ownInvigilations
+            roomsOwnExams = groupWith roomID $ concatMap rooms ownExams
+          in
+            if null ownExams
+              then  -- just invigilator, no own exams
+                   if length roomsOwnInvigilations <= 1
+                then return EverythingOk
+                else do
+                  tell
+                    [ ValidationRecord HardConstraintBroken
+                      $        "Problem in Slot "
+                      `append` showt slotIdxs
+                      `append` ": Invigilator "
+                      `append` invigilatorName invigilator'
+                      `append` " in more than one room: "
+                      `append` showt (map anCode ownInvigilations)
+                    ]
+                  return HardConstraintsBroken
+              else -- invig and own exam (own exam must be in one room)
+                if length roomsOwnInvigilations
+                   <= 1
+                   && length roomsOwnExams
+                   <= 1
+                   && roomID (head $ head roomsOwnInvigilations)
+                   == roomID (head $ head roomsOwnExams)
+                then
+                  return EverythingOk
+                else
+                  do
+                    tell
+                      [ ValidationRecord HardConstraintBroken
+                        $        "Problem in Slot "
+                        `append` showt slotIdxs
+                        `append` ": Invigilator "
+                        `append` invigilatorName invigilator'
+                        `append` " has also own exam in other room(s): "
+                        `append` showt
+                                   (map anCode $ ownExams ++ ownInvigilations)
+                      ]
+                    return HardConstraintsBroken
 
 validateAllOwnSelfOk
   :: Plan
@@ -420,7 +461,8 @@ validateAllOwnSelfOk plan invigilator' examsThatShareRoomsMap = do
 validateHandicapsInvigilator
   :: Plan -> Writer [ValidationRecord] ValidationResult
 validateHandicapsInvigilator plan = do
-  tell [ValidationRecord Info "### Validating handicap invigilators constraints"]
+  tell
+    [ValidationRecord Info "### Validating handicap invigilators constraints"]
   let days' =
         map slotAndNextSlot $ groupWith (fst . fst) $ M.toList $ slots plan
       slotAndNextSlot day' =
@@ -435,11 +477,13 @@ validateHandicapsInvigilator'
   -> Writer [ValidationRecord] ValidationResult
 validateHandicapsInvigilator' ((si@(d1, s1), slot'), ((d2, s2), nextSlot)) = do
   when (d1 /= d2) $ tell
-    [ ValidationRecord HardConstraintBroken
+    [ ValidationRecord
+        HardConstraintBroken
         ">>> This should not happen. Validating handicaps on different days"
     ]
   when (s1 + 1 /= s2) $ tell
-    [ ValidationRecord HardConstraintBroken
+    [ ValidationRecord
+        HardConstraintBroken
         ">>> This should not happen. Validating handicaps on non-following slots"
     ]
   let
diff --git a/stack.yaml b/stack.yaml
@@ -1,4 +1,4 @@
-resolver: lts-13.19
+resolver: lts-13.28
 packages:
   - ./plexams-core
   - ./plexams-datamgmt
diff --git a/stack.yaml.lock b/stack.yaml.lock
@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    size: 500539
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/28.yaml
+    sha256: cdde1bfb38fdee21c6acb73d506e78f7e12e0a73892adbbbe56374ebef4d3adf
+  original: lts-13.28

Original file line number	Diff line number	Diff line change
`@@ -1,4 +1,4 @@`
`1`		`-resolver: lts-13.19`
	`1`	`+resolver: lts-13.28`
`2`	`2`	`packages:`
`3`	`3`	`- ./plexams-core`
`4`	`4`	`- ./plexams-datamgmt`