feat(exams): automatic exam occurrence assignment
This commit is contained in:
Gregor Kleen
parent
f89545f36e
commit
e994fafe28
2
ghci.sh
2
ghci.sh
@ -20,4 +20,4 @@ if [[ -d .stack-work-ghci ]]; then
|
||||
trap move-back EXIT
|
||||
fi
|
||||
|
||||
stack ghci --flag uniworx:dev --flag uniworx:library-only ${@:-uniworx:lib}
|
||||
stack ghci --flag uniworx:dev --flag uniworx:library-only --ghci-options -fobject-code ${@:-uniworx:lib}
|
||||
|
||||
@ -1267,6 +1267,7 @@ BreadcrumbExternalExamGrades: Prüfungsleistungen
|
||||
BreadcrumbExternalExamStaffInvite: Einladung zum Prüfer
|
||||
BreadcrumbParticipantsList: Kursteilnehmerlisten
|
||||
BreadcrumbParticipants: Kursteilnehmerliste
|
||||
BreadcrumbExamAutoOccurrence: Automatische Raumverteilung
|
||||
|
||||
ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn}
|
||||
ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn}
|
||||
@ -1574,7 +1575,7 @@ ExamBonusRoundNonPositive: Vielfaches, auf das gerundet werden soll, muss positi
|
||||
ExamBonusRoundTip: Bonuspunkte werden kaufmännisch auf ein Vielfaches der angegeben Zahl gerundet.
|
||||
|
||||
ExamAutomaticOccurrenceAssignment: Termin- bzw. Raumzuteilung
|
||||
ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden, sich selbstständig einen Raum bzw. Termin aussuchen dürfen oder manuell durch Kursverwalter zugeteilt werden? Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist trotzdem möglich.
|
||||
ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden, sich selbstständig einen Raum bzw. Termin aussuchen dürfen oder manuell durch Kursverwalter zugeteilt werden? Die automatische Verteilung muss von einem Kursverwalter ausgelöst werden und geschieht nicht mit Ablauf einer Frist o.Ä.. Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist somit immer möglich.
|
||||
ExamOccurrenceRule: Verfahren
|
||||
ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilungsverfahren
|
||||
ExamRoomManual': Keine automatische bzw. selbstständige Zuteilung
|
||||
@ -2270,4 +2271,15 @@ ExternalExamUserMustBeStaff: Sie selbst müssen stets assoziierte Person sein, f
|
||||
ExternalExamCourseExists: Der angegebene Kurs existiert im System. Prüfungen sollten daher direkt beim Kurs (statt extern) hinterlegt werden.
|
||||
ExternalExamExists coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ existiert bereits.
|
||||
ExternalExamCreated coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ erfolgreich angelegt.
|
||||
ExternalExamEdited coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ erfolgreich bearbeitet.
|
||||
ExternalExamEdited coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ erfolgreich bearbeitet.
|
||||
|
||||
ExamAutoOccurrenceMinimizeRooms: Verwendete Räume minimieren
|
||||
ExamAutoOccurrenceMinimizeRoomsTip: Soll, für die Aufteilung, die Liste an Räumen zunächst reduziert werden, sodass nur so wenige Räume verwendet werden, wie nötig (größte zuerst)?
|
||||
ExamAutoOccurrenceOccurrencesChangedInFlight: Raumliste wurde verändert
|
||||
ExamAutoOccurrenceParticipantsAssigned num@Int64: Verteilungstabelle erfolgreich gespeichert und #{num} Teilnehmer zugewiesen
|
||||
TitleExamAutoOccurrence tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{tid}-#{ssh}-#{csh} #{examn}: Automatische Raumverteilung
|
||||
BtnExamAutoOccurrenceCalculate: Verteilung berechnen
|
||||
BtnExamAutoOccurrenceAccept: Verteilung akzeptieren
|
||||
ExamRoomMappingSurname: Nachnamen beginnend mit
|
||||
ExamRoomMappingMatriculation: Matrikelnummern endend in
|
||||
ExamRoomLoad: Auslastung
|
||||
@ -1572,7 +1572,7 @@ ExamBonusRoundNonPositive: Rounding multiple must be positive and greater than z
|
||||
ExamBonusRoundTip: Bonus points are rounded commercially to a multiple of the given number
|
||||
|
||||
ExamAutomaticOccurrenceAssignment: Selection of occurrences/rooms for/by participants
|
||||
ExamAutomaticOccurrenceAssignmentTip: Should exam participants be distributed automatically among the configured occurrences/rooms, should they instead be permitted to autonomously choose an occurrence/a room, or should they be assigned to occurrences/rooms manually by course administrators? Manipulation of the distribution and manually assigning participants remains possible.
|
||||
ExamAutomaticOccurrenceAssignmentTip: Should exam participants be distributed automatically among the configured occurrences/rooms, should they instead be permitted to autonomously choose an occurrence/room, or should they be assigned to occurrences/rooms manually by course administrators? Automatic distribution needs to be triggered by a course administrator. It is not done automatically at a predefined time. Thus manipulation of the distribution and manually assigning participants remains possible.
|
||||
ExamOccurrenceRule: Procedure
|
||||
ExamOccurrenceRuleParticipant: Occurrence/room assignment procedure
|
||||
ExamRoomManual': No automatic or autonomous assignment
|
||||
|
||||
@ -4,6 +4,7 @@ Exam
|
||||
gradingRule ExamGradingRule Maybe
|
||||
bonusRule ExamBonusRule Maybe
|
||||
occurrenceRule ExamOccurrenceRule
|
||||
examOccurrenceMapping (ExamOccurrenceMapping ExamOccurrenceName) Maybe
|
||||
visibleFrom UTCTime Maybe
|
||||
registerFrom UTCTime Maybe
|
||||
registerTo UTCTime Maybe
|
||||
|
||||
@ -138,6 +138,7 @@ dependencies:
|
||||
- prometheus-metrics-ghc
|
||||
- wai-middleware-prometheus
|
||||
- extended-reals
|
||||
- rfc5051
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
@ -182,6 +183,8 @@ default-extensions:
|
||||
- DeriveGeneric
|
||||
- DeriveLift
|
||||
- DeriveFunctor
|
||||
- DeriveFoldable
|
||||
- DeriveTraversable
|
||||
- DerivingStrategies
|
||||
- DerivingVia
|
||||
- DataKinds
|
||||
|
||||
1
routes
1
routes
@ -188,6 +188,7 @@
|
||||
/register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result
|
||||
/register/#ExamOccurrenceName ERegisterOccR POST !exam-occurrence-registrationANDtimeANDcapacityANDcourse-registeredAND¬exam-occurrence-registered !exam-occurrence-registrationANDtimeANDexam-occurrence-registeredAND¬exam-result
|
||||
/grades EGradesR GET POST !exam-office
|
||||
/assign-occurrences EAutoOccurrenceR POST
|
||||
/apps CApplicationsR GET POST
|
||||
!/apps/files CAppsFilesR GET
|
||||
/apps/#CryptoFileNameCourseApplication CourseApplicationR:
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE UndecidableInstances, GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Database.Persist.Class.Instances
|
||||
(
|
||||
@ -10,12 +10,15 @@ import ClassyPrelude
|
||||
import Database.Persist.Class
|
||||
import Database.Persist.Types (HaskellName, DBName, PersistValue)
|
||||
import Database.Persist.Types.Instances ()
|
||||
import Database.Persist.Sql
|
||||
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Data.Aeson (ToJSONKey, FromJSONKey)
|
||||
|
||||
|
||||
instance PersistEntity record => Hashable (Key record) where
|
||||
hashWithSalt s = hashWithSalt s . toPersistValue
|
||||
@ -34,3 +37,7 @@ uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistU
|
||||
|
||||
instance PersistEntity record => Eq (Unique record) where
|
||||
(==) = (==) `on` uniqueToMap
|
||||
|
||||
|
||||
deriving newtype instance ToJSONKey (BackendKey SqlBackend)
|
||||
deriving newtype instance FromJSONKey (BackendKey SqlBackend)
|
||||
|
||||
@ -1923,6 +1923,7 @@ instance YesodBreadcrumbs UniWorX where
|
||||
EInviteR -> i18nCrumb MsgBreadcrumbExamParticipantInvite . Just $ CExamR tid ssh csh examn EShowR
|
||||
ERegisterR -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR
|
||||
ERegisterOccR _occn -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR
|
||||
EAutoOccurrenceR -> i18nCrumb MsgBreadcrumbExamAutoOccurrence . Just $ CExamR tid ssh csh examn EUsersR
|
||||
|
||||
breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of
|
||||
TUsersR -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do
|
||||
|
||||
@ -11,3 +11,4 @@ import Handler.Exam.Edit as Handler.Exam
|
||||
import Handler.Exam.Show as Handler.Exam
|
||||
import Handler.Exam.Users as Handler.Exam
|
||||
import Handler.Exam.AddUser as Handler.Exam
|
||||
import Handler.Exam.AutoOccurrence as Handler.Exam
|
||||
|
||||
137
src/Handler/Exam/AutoOccurrence.hs
Normal file
137
src/Handler/Exam/AutoOccurrence.hs
Normal file
@ -0,0 +1,137 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Handler.Exam.AutoOccurrence
|
||||
( examAutoOccurrenceCalculateWidget
|
||||
, postEAutoOccurrenceR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Exam
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Persist.Sql (updateWhereCount)
|
||||
|
||||
|
||||
newtype ExamAutoOccurrenceCalculateForm = ExamAutoOccurrenceCalculateForm
|
||||
{ eaofConfig :: ExamAutoOccurrenceConfig
|
||||
} deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving newtype (Default)
|
||||
|
||||
data ExamAutoOccurrenceAcceptForm = ExamAutoOccurrenceAcceptForm
|
||||
{ eaofMapping :: Maybe (ExamOccurrenceMapping ExamOccurrenceId)
|
||||
, eaofAssignment :: Map UserId (Maybe ExamOccurrenceId)
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
} ''ExamAutoOccurrenceAcceptForm
|
||||
|
||||
data ExamAutoOccurrenceButton
|
||||
= BtnExamAutoOccurrenceCalculate
|
||||
| BtnExamAutoOccurrenceAccept
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
instance Universe ExamAutoOccurrenceButton
|
||||
instance Finite ExamAutoOccurrenceButton
|
||||
|
||||
nullaryPathPiece ''ExamAutoOccurrenceButton $ camelToPathPiece' 4
|
||||
|
||||
embedRenderMessage ''UniWorX ''ExamAutoOccurrenceButton id
|
||||
instance Button UniWorX ExamAutoOccurrenceButton where
|
||||
btnClasses _ = [BCIsButton, BCPrimary]
|
||||
|
||||
|
||||
examAutoOccurrenceCalculateForm :: ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm
|
||||
examAutoOccurrenceCalculateForm ExamAutoOccurrenceCalculateForm{ eaofConfig }
|
||||
= identifyForm FIDExamAutoOccurrenceCalculate . renderAForm FormStandard $ ExamAutoOccurrenceCalculateForm <$> eaocForm
|
||||
where
|
||||
eaocForm =
|
||||
(set _eaocMinimizeRooms <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just $ eaofConfig ^. _eaocMinimizeRooms))
|
||||
<*> pure def
|
||||
|
||||
examAutoOccurrenceAcceptForm :: Maybe ExamAutoOccurrenceAcceptForm -> Form ExamAutoOccurrenceAcceptForm
|
||||
examAutoOccurrenceAcceptForm confirmData = identifyForm FIDExamAutoOccurrenceConfirm $ \html -> do
|
||||
(confirmDataRes, confirmDataView) <- mreq secretJsonField "" confirmData
|
||||
(acceptRes, acceptView) <- buttonForm' [BtnExamAutoOccurrenceAccept] mempty
|
||||
return (acceptRes *> confirmDataRes, toWidget html <> fvInput confirmDataView <> acceptView)
|
||||
|
||||
|
||||
examAutoOccurrenceCalculateWidget :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Widget
|
||||
examAutoOccurrenceCalculateWidget tid ssh csh examn = do
|
||||
(formView, formEncoding) <- liftHandler . generateFormPost $ examAutoOccurrenceCalculateForm def
|
||||
|
||||
wrapForm' BtnExamAutoOccurrenceCalculate formView def
|
||||
{ formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
|
||||
, formEncoding
|
||||
}
|
||||
|
||||
|
||||
postEAutoOccurrenceR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
postEAutoOccurrenceR tid ssh csh examn = do
|
||||
(Entity eId Exam{ examOccurrenceRule }, occurrences) <- runDB $ do
|
||||
exam@(Entity eId _) <- fetchExam tid ssh csh examn
|
||||
occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [ Asc ExamOccurrenceName ]
|
||||
return (exam, occurrences)
|
||||
|
||||
|
||||
((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm def
|
||||
|
||||
calcResult <- formResultMaybe calculateRes $ \ExamAutoOccurrenceCalculateForm{..} -> runDB $ do
|
||||
participants <- E.select . E.from $ \(registration `E.InnerJoin` user) -> do
|
||||
E.on $ registration E.^. ExamRegistrationUser E.==. user E.^. UserId
|
||||
E.where_ $ registration E.^. ExamRegistrationExam E.==. E.val eId
|
||||
return (user, registration)
|
||||
let participants' = Map.fromList $ do
|
||||
(Entity uid userRec, Entity _ ExamRegistration{..}) <- participants
|
||||
return (uid, (userRec, examRegistrationOccurrence))
|
||||
occurrences' = Map.fromList $ map (\(Entity eoId ExamOccurrence{..}) -> (eoId, examOccurrenceCapacity)) occurrences
|
||||
(eaofMapping, eaofAssignment) = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants'
|
||||
return $ Just ExamAutoOccurrenceAcceptForm{..}
|
||||
|
||||
((confirmRes, confirmView), confirmEncoding) <- runFormPost $ examAutoOccurrenceAcceptForm calcResult
|
||||
let confirmWidget = wrapForm confirmView def
|
||||
{ formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
|
||||
, formEncoding = confirmEncoding
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
|
||||
formResult confirmRes $ \ExamAutoOccurrenceAcceptForm{..} -> do
|
||||
Sum assignedCount <- runDB $ do
|
||||
let eaofMapping'' :: Maybe (Maybe (ExamOccurrenceMapping ExamOccurrenceName))
|
||||
eaofMapping'' = (<$> eaofMapping) . traverseExamOccurrenceMapping $ \eoId -> case filter ((== eoId) . entityKey) occurrences of
|
||||
[Entity _ ExamOccurrence{..}] -> Just examOccurrenceName
|
||||
_other -> Nothing
|
||||
eaofMapping' <- case eaofMapping'' of
|
||||
Nothing -> return Nothing
|
||||
Just Nothing -> invalidArgsI [MsgExamAutoOccurrenceOccurrencesChangedInFlight]
|
||||
Just (Just x ) -> return $ Just x
|
||||
update eId [ ExamExamOccurrenceMapping =. eaofMapping' ]
|
||||
fmap fold . iforM eaofAssignment $ \pid occ -> case occ of
|
||||
Just _ -> Sum <$> updateWhereCount [ ExamRegistrationExam ==. eId, ExamRegistrationUser ==. pid, ExamRegistrationOccurrence ==. Nothing ] [ ExamRegistrationOccurrence =. occ ]
|
||||
Nothing -> return mempty
|
||||
addMessageI Success $ MsgExamAutoOccurrenceParticipantsAssigned assignedCount
|
||||
redirect $ CExamR tid ssh csh examn EUsersR
|
||||
|
||||
ExamAutoOccurrenceAcceptForm{..} <- maybe (redirect $ CExamR tid ssh csh examn EUsersR) return calcResult
|
||||
|
||||
let heading = MsgTitleExamAutoOccurrence tid ssh csh examn
|
||||
mappingWgt
|
||||
= let occLoads :: Map ExamOccurrenceId Natural
|
||||
occLoads = Map.fromListWith (+) . mapMaybe (\(_, mOcc) -> (, 1) <$> mOcc) $ Map.toList eaofAssignment
|
||||
|
||||
occLoad = fromMaybe 0 . flip Map.lookup occLoads
|
||||
|
||||
occMappingRule = examOccurrenceMappingRule <$> eaofMapping
|
||||
|
||||
loadProp curr max'
|
||||
| max' /= 0 = MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max')
|
||||
| otherwise = MsgProportionNoRatio (toMessage curr) (toMessage max')
|
||||
|
||||
occMapping occId = examOccurrenceMappingDescriptionWidget <$> occMappingRule <*> (Map.lookup occId . examOccurrenceMappingMapping =<< eaofMapping)
|
||||
in $(widgetFile "widgets/exam-occurrence-mapping")
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
$(widgetFile "exam/auto-occurrence-confirm")
|
||||
@ -35,6 +35,7 @@ postEEditR tid ssh csh examn = do
|
||||
, examGradingRule = efGradingRule
|
||||
, examBonusRule = efBonusRule
|
||||
, examOccurrenceRule = efOccurrenceRule
|
||||
, examExamOccurrenceMapping = examExamOccurrenceMapping oldExam
|
||||
, examVisibleFrom = efVisibleFrom
|
||||
, examRegisterFrom = efRegisterFrom
|
||||
, examRegisterTo = efRegisterTo
|
||||
|
||||
@ -32,6 +32,7 @@ postCExamNewR tid ssh csh = do
|
||||
, examGradingRule = efGradingRule
|
||||
, examBonusRule = efBonusRule
|
||||
, examOccurrenceRule = efOccurrenceRule
|
||||
, examExamOccurrenceMapping = Nothing
|
||||
, examVisibleFrom = efVisibleFrom
|
||||
, examRegisterFrom = efRegisterFrom
|
||||
, examRegisterTo = efRegisterTo
|
||||
|
||||
@ -145,6 +145,7 @@ getEShowR tid ssh csh examn = do
|
||||
showAchievedPoints = not $ null results
|
||||
showOccurrenceRegisterColumn = occurrenceAssignmentsShown || (mayRegister && examOccurrenceRule == ExamRoomFifo)
|
||||
markUnregisteredOccurrences mOcc = occurrenceAssignmentsShown && hasRegistration && isn't _Just (registerWidget mOcc)
|
||||
showOccurrenceMappingColumn = examOccurrenceRuleAutomatic examOccurrenceRule && occurrenceAssignmentsShown && is _Just examExamOccurrenceMapping
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh $ CI.original examName
|
||||
|
||||
@ -161,4 +162,7 @@ getEShowR tid ssh csh examn = do
|
||||
|
||||
examBonusW :: ExamBonusRule -> Widget
|
||||
examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
|
||||
|
||||
occurrenceMapping :: ExamOccurrenceName -> Maybe Widget
|
||||
occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (fmap examOccurrenceMappingMapping examExamOccurrenceMapping >>= Map.lookup occName)
|
||||
$(widgetFile "exam-show")
|
||||
|
||||
@ -11,6 +11,8 @@ import Handler.Utils.Exam
|
||||
import Handler.Utils.Users
|
||||
import Handler.Utils.Csv
|
||||
|
||||
import Handler.Exam.AutoOccurrence (examAutoOccurrenceCalculateWidget)
|
||||
|
||||
import Handler.ExamOffice.Exam (examCloseWidget)
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
@ -390,7 +392,7 @@ embedRenderMessage ''UniWorX ''ExamUserCsvException id
|
||||
getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
getEUsersR = postEUsersR
|
||||
postEUsersR tid ssh csh examn = do
|
||||
(((Any computedValues, registrationResult), examUsersTable), Entity eId examVal, bonus) <- runDB $ do
|
||||
(((Any computedValues, registrationResult), examUsersTable), Entity eId examVal@Exam{..}, bonus) <- runDB $ do
|
||||
exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn
|
||||
examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName]
|
||||
bonus <- examBonus exam
|
||||
|
||||
@ -1,12 +1,17 @@
|
||||
{-# OPTIONS_GHC -fno-warn-deprecations #-}
|
||||
|
||||
module Handler.Utils.Exam
|
||||
( fetchExamAux
|
||||
, fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
|
||||
, examBonus, examBonusPossible, examBonusAchieved
|
||||
, examResultBonus, examGrade
|
||||
, ExamAutoOccurrenceConfig
|
||||
, eaocMinimizeRooms, eaocFinenessCost
|
||||
, _eaocMinimizeRooms, _eaocFinenessCost
|
||||
, examAutoOccurrence
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (distribute)
|
||||
import Import.NoFoundation
|
||||
|
||||
import Database.Persist.Sql (SqlBackendCanRead)
|
||||
import qualified Database.Esqueleto as E
|
||||
@ -26,7 +31,7 @@ import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Control.Monad.Trans.Random.Lazy (evalRand)
|
||||
import System.Random (mkStdGen)
|
||||
import Control.Monad.Random.Class (weightedMay)
|
||||
import Control.Monad.Random.Class (weighted)
|
||||
import Control.Monad.ST (ST, runST)
|
||||
|
||||
import Data.Array (Array)
|
||||
@ -40,9 +45,10 @@ import qualified Data.List as List
|
||||
|
||||
import Data.ExtendedReal
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Char as Char
|
||||
|
||||
import qualified Data.RFC5051 as RFC5051
|
||||
|
||||
|
||||
fetchExamAux :: ( SqlBackendCanRead backend
|
||||
, E.SqlSelect b a
|
||||
@ -184,17 +190,32 @@ examGrade Exam{..} mBonus (otoList -> results)
|
||||
where
|
||||
lowerBounds :: [(ExamGrade, Points)]
|
||||
lowerBounds = zip [Grade40, Grade37 ..] examGradingKey'
|
||||
|
||||
data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig
|
||||
{ eaocMinimizeRooms :: Bool
|
||||
, eaocFinenessCost :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Default ExamAutoOccurrenceConfig where
|
||||
def = ExamAutoOccurrenceConfig
|
||||
{ eaocMinimizeRooms = False
|
||||
, eaocFinenessCost = 0.2
|
||||
}
|
||||
|
||||
makeLenses_ ''ExamAutoOccurrenceConfig
|
||||
|
||||
|
||||
examAutoOccurrence :: forall seed.
|
||||
Hashable seed
|
||||
=> seed
|
||||
-> ExamOccurrenceRule
|
||||
-> ExamAutoOccurrenceConfig
|
||||
-> Map ExamOccurrenceId Natural
|
||||
-> Map UserId (User, Maybe ExamOccurrenceId)
|
||||
-> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
|
||||
examAutoOccurrence (hash -> seed) rule occurrences users
|
||||
examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users
|
||||
| sum occurrences < usersCount
|
||||
|| sum occurrences <= 0
|
||||
|| Map.null users
|
||||
= nullResult
|
||||
| otherwise
|
||||
@ -203,8 +224,8 @@ examAutoOccurrence (hash -> seed) rule occurrences users
|
||||
-> ( Nothing
|
||||
, flip Map.mapWithKey users $ \uid (_, mOcc)
|
||||
-> let randomOcc = flip evalRand (mkStdGen $ hashWithSalt seed uid) $
|
||||
weightedMay $ over _2 fromIntegral <$> occurrences'
|
||||
in mOcc <|> randomOcc
|
||||
weighted $ over _2 fromIntegral <$> occurrences'
|
||||
in Just $ fromMaybe randomOcc mOcc
|
||||
)
|
||||
_ | Just (postprocess -> (resMapping, result)) <- bestOption
|
||||
-> ( Just $ ExamOccurrenceMapping rule resMapping
|
||||
@ -221,38 +242,21 @@ examAutoOccurrence (hash -> seed) rule occurrences users
|
||||
users' = case rule of
|
||||
ExamRoomSurname
|
||||
-> Map.fromListWith Set.union
|
||||
[ (map CI.mk $ unpack userSurname', Set.singleton uid)
|
||||
[ (map CI.mk $ unpack userSurname, Set.singleton uid)
|
||||
| (uid, (User{..}, Nothing)) <- Map.toList users
|
||||
, let userSurname' = Text.filter Char.isLetter userSurname
|
||||
, not $ null userSurname'
|
||||
, not $ null userSurname
|
||||
]
|
||||
ExamRoomMatriculation
|
||||
-> let matrUsers
|
||||
= Map.fromListWith Set.union
|
||||
[ (map CI.mk $ unpack matriculation', Set.singleton uid)
|
||||
| (uid, (User{..}, Nothing)) <- Map.toList users
|
||||
, let Just matriculation' = Text.filter Char.isDigit <$> userMatrikelnummer
|
||||
, let Just matriculation' = userMatrikelnummer
|
||||
, not $ null matriculation'
|
||||
]
|
||||
in Map.mapKeysWith Set.union (take . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers
|
||||
_ -> Map.singleton [] $ Map.keysSet users
|
||||
|
||||
usersGroups :: Natural -- ^ fineness
|
||||
-> Map [CI Char] (Set UserId)
|
||||
-- ^ Partition users into monotonously finer
|
||||
usersGroups (fromIntegral -> c) = Map.mapKeysWith Set.union restr users'
|
||||
where
|
||||
restr = case rule of
|
||||
ExamRoomSurname
|
||||
-> take c
|
||||
ExamRoomMatriculation
|
||||
-> reverse . take c . reverse
|
||||
_other
|
||||
-> id
|
||||
|
||||
maximumFineness :: Natural
|
||||
-- ^ Fineness at which `usersGroups` becomes constant
|
||||
maximumFineness = fromIntegral . F.maximum . Set.map length $ Map.keysSet users'
|
||||
|
||||
occurrences' :: [(ExamOccurrenceId, Natural)]
|
||||
-- ^ Minimise number of occurrences used
|
||||
@ -262,6 +266,8 @@ examAutoOccurrence (hash -> seed) rule occurrences users
|
||||
-- If a single occurrence can accomodate all participants, pick the one with
|
||||
-- the least capacity
|
||||
occurrences'
|
||||
| not eaocMinimizeRooms
|
||||
= Map.toList occurrences
|
||||
| Just largeEnoughs <- fromNullable . filter ((>= usersCount) . view _2) $ Map.toList occurrences
|
||||
= pure $ minimumBy (comparing $ view _2) largeEnoughs
|
||||
| otherwise
|
||||
@ -278,24 +284,12 @@ examAutoOccurrence (hash -> seed) rule occurrences users
|
||||
, occ : accOccs
|
||||
)
|
||||
|
||||
largestOccurrence :: Num a => a
|
||||
largestOccurrence = fromIntegral . maximum . mapNonNull (view _2) $ impureNonNull occurrences'
|
||||
|
||||
finenessCost :: Natural -> Natural
|
||||
finenessCost x = round (finenessConst * largestOccurrence) * fromIntegral (length occurrences') * x * x
|
||||
where
|
||||
finenessConst :: Rational
|
||||
-- ^ Cost (scaled to proportion of occurrence) of having higher fineness
|
||||
finenessConst = 1 % 5 -- TODO: tweak
|
||||
|
||||
|
||||
distribute :: forall wordId lineId cost.
|
||||
( Num cost
|
||||
, Ord wordId, Ord lineId
|
||||
)
|
||||
_
|
||||
=> [(wordId, Natural)]
|
||||
-> [(lineId, Natural)]
|
||||
-> Maybe (cost, Map lineId (Set wordId))
|
||||
-> (wordId -> wordId -> Extended Rational)
|
||||
-> Maybe (cost, [(lineId, [wordId])])
|
||||
-- ^ Distribute the given items (@wordId@s) with associated size in
|
||||
-- contiguous blocks into the given buckets (@lineId@s) such that they are
|
||||
-- filled as evenly as possible (proportionally)
|
||||
@ -303,8 +297,8 @@ examAutoOccurrence (hash -> seed) rule occurrences users
|
||||
-- Return a cost scaled to item-size squared
|
||||
--
|
||||
-- See <https://xxyxyz.org/line-breaking/> under \"Shortest Path\"
|
||||
distribute wordLengths lineLengths
|
||||
| null wordLengths = Just (0, Map.empty)
|
||||
distribute wordLengths lineLengths breakCost
|
||||
| null wordLengths = Just (0, [ (l, []) | (l, _) <- lineLengths ])
|
||||
| null lineLengths = Nothing
|
||||
| otherwise = let (cost, result) = distribute'
|
||||
in case cost of
|
||||
@ -344,7 +338,7 @@ examAutoOccurrence (hash -> seed) rule occurrences users
|
||||
|
||||
bounds = (0, Map.size wordMap)
|
||||
|
||||
distribute' :: (Extended Rational, Map lineId (Set wordId))
|
||||
distribute' :: (Extended Rational, [(lineId, [wordId])])
|
||||
distribute' = runST $ do
|
||||
minima <- ST.newListArray (0, Map.size wordMap) $ 0 : repeat PosInf :: forall s. ST s (STArray s Int (Extended Rational))
|
||||
breaks <- ST.newArray (0, Map.size wordMap) 0 :: forall s. ST s (STUArray s Int Int)
|
||||
@ -363,7 +357,22 @@ examAutoOccurrence (hash -> seed) rule occurrences users
|
||||
| otherwise
|
||||
= 0
|
||||
w = offsets Array.! j - offsets Array.! i
|
||||
cost <- (+) (widthCost potWidth w) <$> ST.readArray minima i
|
||||
prevMin <- ST.readArray minima i
|
||||
let cost = prevMin + widthCost potWidth w + breakCost'
|
||||
breakCost'
|
||||
| j < Map.size wordMap
|
||||
, j > 0
|
||||
= breakCost (wordIx # pred j) (wordIx # j)
|
||||
| otherwise
|
||||
= 0
|
||||
traceM $ show ( i
|
||||
, j
|
||||
, potWidth
|
||||
, w
|
||||
, (fromRational :: Rational -> Centi) <$> prevMin
|
||||
, (fromRational :: Rational -> Centi) <$> widthCost potWidth w
|
||||
, (fromRational :: Rational -> Centi) <$> breakCost'
|
||||
)
|
||||
when (isFinite cost) $ do
|
||||
minCost <- ST.readArray minima j
|
||||
when (cost < minCost) $ do
|
||||
@ -372,66 +381,119 @@ examAutoOccurrence (hash -> seed) rule occurrences users
|
||||
go i' $ succ j
|
||||
| otherwise = return ()
|
||||
in go i' $ succ i'
|
||||
traceM . show . map (fmap (fromRational :: Rational -> Centi)) =<< ST.getElems minima
|
||||
traceM . show =<< ST.getElems breaks
|
||||
|
||||
let accumResult lineIx j (accCost, accMap) = do
|
||||
i <- ST.readArray breaks j
|
||||
accCost' <- (+) accCost <$> ST.readArray minima j
|
||||
traceM $ show (accCost', lineIx, [i .. pred j])
|
||||
let accMap' = Map.insertWith Set.union (lineIxs List.!! lineIx) (Set.fromList $ map (review wordIx) [i .. pred j]) accMap
|
||||
traceM $ show ((fromRational :: Rational -> Centi) <$> accCost', lineIx, (i, pred j))
|
||||
let accMap' = (lineIxs List.!! lineIx, map (review wordIx) [i .. pred j]) : accMap
|
||||
if
|
||||
| i > 0 -> accumResult (succ lineIx) i (accCost', accMap')
|
||||
| otherwise -> return (accCost', accMap')
|
||||
lineIxs = reverse $ map (view _1) lineLengths
|
||||
in accumResult 0 (Map.size wordMap) (0, Map.empty)
|
||||
in accumResult 0 (Map.size wordMap) (0, [])
|
||||
|
||||
|
||||
widthCost :: Natural -> Natural -> Extended Rational
|
||||
widthCost lineWidth w
|
||||
| lineWidth < w = PosInf
|
||||
| otherwise = Finite (((fromIntegral lineWidth % fromIntegral w) - optimumRatio) * fromIntegral longestLine) ^ 2
|
||||
| otherwise = Finite (max 1 . abs $ ((fromIntegral w % fromIntegral lineWidth) - optimumRatio) * fromIntegral longestLine) ^ 2
|
||||
where
|
||||
optimumRatio = ((%) `on` fromIntegral . sum) (map (view _2) lineLengths) (map (view _2) wordLengths)
|
||||
optimumRatio = ((%) `on` fromIntegral . sum) (map (view _2) wordLengths) (map (view _2) lineLengths)
|
||||
|
||||
charCost :: [CI Char] -> [CI Char] -> Extended Rational
|
||||
charCost pA pB = Finite (max 1 $ List.genericLength (pA `lcp` pB) * eaocFinenessCost * fromIntegral longestLine) ^ 2
|
||||
where
|
||||
longestLine = maximum . mapNonNull (view _2) $ impureNonNull occurrences'
|
||||
|
||||
options :: [(Natural, (Natural, Map ExamOccurrenceId (Set [CI Char])))]
|
||||
options = do
|
||||
fineness <- [0..maximumFineness]
|
||||
|
||||
let usersGroups' = fromIntegral . Set.size <$> usersGroups fineness
|
||||
|
||||
traceM $ show usersGroups'
|
||||
traceM . show $ map snd occurrences'
|
||||
|
||||
-- The algorithm used in `distribute` produces no usable result if the
|
||||
-- situation occurs, that a single item does not fit within a bucket.
|
||||
-- In a naive attempt to prevent this we ensure that all items fit into
|
||||
-- all buckets.
|
||||
guard . (\(fromIntegral -> maxSize) -> all ((>= maxSize) . view _2) occurrences') . maybe 0 maximum $ fromNullable usersGroups'
|
||||
lcp :: Eq a => [a] -> [a] -> [a]
|
||||
-- ^ Longest common prefix
|
||||
lcp [] _ = []
|
||||
lcp _ [] = []
|
||||
lcp (a:as) (b:bs)
|
||||
| a == b = a:lcp as bs
|
||||
| otherwise = []
|
||||
|
||||
let
|
||||
packets :: [([CI Char], Natural)]
|
||||
packets = Map.toAscList usersGroups'
|
||||
(resultCost, result) <- hoistMaybe $ distribute packets occurrences'
|
||||
bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])]
|
||||
bestOption = do
|
||||
(_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' charCost
|
||||
|
||||
traceM $ show (fineness, finenessCost fineness, resultCost)
|
||||
traceM . show . map (foldMap $ \prefix -> Sum $ usersGroups' Map.! prefix) $ Map.elems result
|
||||
|
||||
return (fineness, (resultCost, result))
|
||||
bestOption :: Maybe (Map ExamOccurrenceId (Set [CI Char]))
|
||||
bestOption = options
|
||||
& over _tail (takeWhile $ \(fineness, (resCost, _)) -> finenessCost fineness <= resCost)
|
||||
& map (view $ _2 . _2)
|
||||
& fmap last . fromNullable
|
||||
-- traceM $ show cost
|
||||
|
||||
postprocess :: Map ExamOccurrenceId (Set [CI Char])
|
||||
-> ( [(ExamOccurrenceId, [CI Char])]
|
||||
return res
|
||||
|
||||
postprocess :: [(ExamOccurrenceId, [[CI Char]])]
|
||||
-> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
|
||||
, Map UserId (Maybe ExamOccurrenceId)
|
||||
)
|
||||
postprocess result = (resultAscList, resultUsers)
|
||||
where
|
||||
resultAscList = sortOn (view _2) . map (over _2 Set.findMax) $ Map.toList result
|
||||
resultAscList = Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result
|
||||
where
|
||||
accRes _ [] = []
|
||||
accRes prevEnd ((occA, nsA) : (occB, nsB) : xs)
|
||||
| Just minA <- prevEnd <|> preview _head nsA
|
||||
, Just maxA <- nsA ^? _last
|
||||
, Just minB <- nsB ^? _head
|
||||
= let common = maxA `lcp` minB
|
||||
mayRange' = mayRange . max 1 . succ $ length common
|
||||
suffA = CI.foldedCase <$> drop (length common) maxA
|
||||
suffB = CI.foldedCase <$> drop (length common) minB
|
||||
in if
|
||||
| mayRange (succ $ length common) maxA
|
||||
, mayRange (succ $ length common) minA
|
||||
, mayRange (succ $ length common) minB
|
||||
, firstA : _ <- suffA
|
||||
, firstB : _ <- suffB
|
||||
-> let break' = (occSize occA * Char.ord firstA + occSize occB * Char.ord firstB) % (occSize occA + occSize occB)
|
||||
& floor
|
||||
& Char.chr
|
||||
& Char.toUpper
|
||||
& CI.mk
|
||||
& pure
|
||||
& (common ++)
|
||||
succBreak = fmap reverse . go $ reverse break'
|
||||
where
|
||||
go [] = Nothing
|
||||
go (c:cs)
|
||||
| c' <- CI.map succ c
|
||||
, c' `Set.member` rangeAlphabet
|
||||
= Just $ c' : cs
|
||||
| otherwise
|
||||
= go cs
|
||||
in (occA, Set.insert (ExamOccurrenceMappingRange minA break') . Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ length common)) . Set.filter (not . mayRange') $ Set.fromList nsA) : accRes succBreak ((occB, nsB) : xs)
|
||||
| otherwise
|
||||
-> (occA, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ length common)) $ Set.fromList nsA) : accRes prevEnd ((occB, nsB) : xs)
|
||||
| null nsA
|
||||
= accRes prevEnd $ (occB, nsB) : xs
|
||||
| otherwise -- null nsB
|
||||
= accRes prevEnd $ (occA, nsA) : xs
|
||||
accRes prevEnd [(occZ, nsZ)]
|
||||
| Just minAlpha <- Set.lookupMin rangeAlphabet
|
||||
, Just maxAlpha <- Set.lookupMax rangeAlphabet
|
||||
, minZ <- fromMaybe (pure minAlpha) prevEnd
|
||||
= let commonLength = max 1 $ length minZ
|
||||
in pure (occZ, Set.insert (ExamOccurrenceMappingRange minZ $ replicate commonLength maxAlpha) . Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsZ)
|
||||
| otherwise
|
||||
= pure (occZ, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsZ)
|
||||
resultUsers = Map.fromList $ do
|
||||
(occId, buckets) <- Map.toList result
|
||||
user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> b `List.isPrefixOf` b') $ Map.toList users') buckets
|
||||
(occId, buckets) <- result
|
||||
user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> b == b') $ Map.toList users') buckets
|
||||
return (user, Just occId)
|
||||
|
||||
occSize :: Num a => ExamOccurrenceId -> a
|
||||
occSize occId = fromIntegral . length $ Map.filter (== Just occId) resultUsers
|
||||
|
||||
rangeAlphabet :: Set (CI Char)
|
||||
rangeAlphabet
|
||||
| ExamRoomSurname <- rule
|
||||
= Set.fromList $ map CI.mk ['A'..'Z']
|
||||
| ExamRoomMatriculation <- rule
|
||||
= Set.fromList $ map CI.mk ['0'..'9']
|
||||
| otherwise
|
||||
= mempty
|
||||
mayRange :: Int -> [CI Char] -> Bool
|
||||
mayRange l = all (`Set.member` rangeAlphabet) . take l
|
||||
|
||||
@ -8,6 +8,8 @@ import Text.Hamlet (shamletFile)
|
||||
|
||||
import Handler.Utils.DateTime
|
||||
|
||||
import qualified Data.Char as Char
|
||||
|
||||
|
||||
---------
|
||||
-- Simple utilities for consistent display
|
||||
@ -102,3 +104,14 @@ i18n :: forall m msg.
|
||||
, RenderMessage (HandlerSite m) msg
|
||||
) => msg -> m ()
|
||||
i18n = toWidget . (SomeMessage :: msg -> SomeMessage (HandlerSite m))
|
||||
|
||||
|
||||
examOccurrenceMappingDescriptionWidget :: ExamOccurrenceRule -> Set ExamOccurrenceMappingDescription -> Widget
|
||||
examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets/exam-occurrence-mapping-description")
|
||||
where
|
||||
titleCase = over _head Char.toUpper . map CI.foldedCase
|
||||
doPrefix
|
||||
| ExamRoomMatriculation <- rule
|
||||
= False
|
||||
| otherwise
|
||||
= True
|
||||
|
||||
@ -37,6 +37,12 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll
|
||||
submissionRatingDone :: Submission -> Bool
|
||||
submissionRatingDone Submission{..} = isJust submissionRatingTime
|
||||
|
||||
|
||||
deriving newtype instance ToJSONKey UserId
|
||||
deriving newtype instance FromJSONKey UserId
|
||||
deriving newtype instance ToJSONKey ExamOccurrenceId
|
||||
deriving newtype instance FromJSONKey ExamOccurrenceId
|
||||
|
||||
-- ToMarkup and ToMessage instances for displaying selected database primary keys
|
||||
|
||||
instance ToMarkup (Key School) where
|
||||
|
||||
@ -11,7 +11,14 @@ module Model.Types.Exam
|
||||
, _examResult
|
||||
, ExamBonusRule(..)
|
||||
, ExamOccurrenceRule(..)
|
||||
, examOccurrenceRuleAutomatic
|
||||
, ExamOccurrenceMappingDescription(..)
|
||||
, _eaomrStart, _eaomrEnd, _eaomrSpecial
|
||||
, _ExamOccurrenceMappingRange, _ExamOccurrenceMappingSpecial
|
||||
, ExamOccurrenceMapping(..)
|
||||
, _examOccurrenceMappingRule
|
||||
, _examOccurrenceMappingMapping
|
||||
, traverseExamOccurrenceMapping
|
||||
, ExamGrade(..)
|
||||
, numberGrade
|
||||
, ExamGradeDefCenter(..)
|
||||
@ -28,6 +35,8 @@ import Import.NoModel
|
||||
import Model.Types.Common
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Utils.Lens.TH
|
||||
|
||||
@ -44,6 +53,8 @@ import Text.Blaze (ToMarkup(..))
|
||||
|
||||
import qualified Data.Foldable
|
||||
|
||||
import Data.Aeson (genericToJSON, genericParseJSON)
|
||||
|
||||
|
||||
data ExamResult' res = ExamAttended { examResult :: res }
|
||||
| ExamNoShow
|
||||
@ -152,18 +163,51 @@ deriveJSON defaultOptions
|
||||
, tagSingleConstructors = True
|
||||
} ''ExamOccurrenceRule
|
||||
derivePersistFieldJSON ''ExamOccurrenceRule
|
||||
makePrisms ''ExamOccurrenceRule
|
||||
|
||||
examOccurrenceRuleAutomatic :: ExamOccurrenceRule -> Bool
|
||||
examOccurrenceRuleAutomatic x = or $ map ($ x)
|
||||
[ is _ExamRoomSurname
|
||||
, is _ExamRoomMatriculation
|
||||
, is _ExamRoomRandom
|
||||
]
|
||||
|
||||
data ExamOccurrenceMappingDescription
|
||||
= ExamOccurrenceMappingRange { eaomrStart, eaomrEnd :: [CI Char] }
|
||||
| ExamOccurrenceMappingSpecial { eaomrSpecial :: [CI Char] }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
, constructorTagModifier = camelToPathPiece' 3
|
||||
} ''ExamOccurrenceMappingDescription
|
||||
|
||||
makeLenses_ ''ExamOccurrenceMappingDescription
|
||||
makePrisms ''ExamOccurrenceMappingDescription
|
||||
|
||||
data ExamOccurrenceMapping roomId = ExamOccurrenceMapping
|
||||
{ examOccurrenceMappingRule :: ExamOccurrenceRule
|
||||
, examOccurrenceMappingMapping :: [(roomId, [CI Char])]
|
||||
, examOccurrenceMappingMapping :: Map roomId (Set ExamOccurrenceMappingDescription)
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 3
|
||||
, constructorTagModifier = camelToPathPiece' 1
|
||||
, tagSingleConstructors = False
|
||||
} ''ExamOccurrenceMapping
|
||||
instance ToJSONKey roomId => ToJSON (ExamOccurrenceMapping roomId) where
|
||||
toJSON = genericToJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 3
|
||||
, constructorTagModifier = camelToPathPiece' 1
|
||||
, tagSingleConstructors = False
|
||||
}
|
||||
instance (FromJSONKey roomId, Ord roomId) => FromJSON (ExamOccurrenceMapping roomId) where
|
||||
parseJSON = genericParseJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 3
|
||||
, constructorTagModifier = camelToPathPiece' 1
|
||||
, tagSingleConstructors = False
|
||||
}
|
||||
derivePersistFieldJSON ''ExamOccurrenceMapping
|
||||
|
||||
makeLenses_ ''ExamOccurrenceMapping
|
||||
|
||||
traverseExamOccurrenceMapping :: Ord roomId'
|
||||
=> Traversal (ExamOccurrenceMapping roomId) (ExamOccurrenceMapping roomId') roomId roomId'
|
||||
traverseExamOccurrenceMapping = _examOccurrenceMappingMapping . iso Map.toList (Map.fromListWith Set.union) . traverse . _1
|
||||
|
||||
|
||||
data ExamGrade
|
||||
= Grade50
|
||||
|
||||
@ -229,6 +229,7 @@ data FormIdentifier
|
||||
| FIDUserAuthMode
|
||||
| FIDAllUsersAction
|
||||
| FIDLanguage
|
||||
| FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
||||
instance PathPiece FormIdentifier where
|
||||
|
||||
@ -277,6 +277,13 @@ packages:
|
||||
sha256: 6d64803c639ed4c7204ea6fab0536b97d3ee16cdecb9b4a883cd8e56d3c61402
|
||||
original:
|
||||
hackage: wai-middleware-prometheus-1.0.0
|
||||
- completed:
|
||||
hackage: extended-reals-0.2.3.0@sha256:78a498d703fffcecfba8e66cfb3e64c4307b2c126a442f6d28cfdd997829f1bf,1563
|
||||
pantry-tree:
|
||||
size: 398
|
||||
sha256: 29629bb0ac41c49671b7f792e540165ee091eb24ffd0eaff229a2f40cc03f3af
|
||||
original:
|
||||
hackage: extended-reals-0.2.3.0
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 498180
|
||||
|
||||
@ -114,6 +114,22 @@ $if not (null occurrences)
|
||||
_{MsgExamRoomAssigned}
|
||||
$if not occurrenceAssignmentsVisible
|
||||
\ ^{isVisible False}
|
||||
$if showOccurrenceMappingColumn
|
||||
$case fmap examOccurrenceMappingRule examExamOccurrenceMapping
|
||||
$of Just ExamRoomSurname
|
||||
<th .table__th>
|
||||
_{MsgExamRoomMappingSurname}
|
||||
$if not occurrenceAssignmentsVisible
|
||||
\ ^{isVisible False}
|
||||
$of Just ExamRoomMatriculation
|
||||
<th .table__th>
|
||||
_{MsgExamRoomMappingMatriculation}
|
||||
$if not occurrenceAssignmentsVisible
|
||||
\ ^{isVisible False}
|
||||
$of _
|
||||
<th .table__td>
|
||||
$if not occurrenceAssignmentsVisible
|
||||
^{isVisible False}
|
||||
<th .table__th>_{MsgExamRoomDescription}
|
||||
<tbody>
|
||||
$forall (occurrence, registered) <- occurrences
|
||||
@ -133,6 +149,10 @@ $if not (null occurrences)
|
||||
$nothing
|
||||
$if registered
|
||||
#{iconOK}
|
||||
$if showOccurrenceMappingColumn
|
||||
<td .table__td>
|
||||
$maybe mappingWgt <- occurrenceMapping examOccurrenceName
|
||||
^{mappingWgt}
|
||||
<td .table__td>
|
||||
$maybe desc <- examOccurrenceDescription
|
||||
#{desc}
|
||||
|
||||
@ -1,6 +1,9 @@
|
||||
$newline never
|
||||
<section>
|
||||
^{closeWgt}
|
||||
$if examOccurrenceRuleAutomatic examOccurrenceRule
|
||||
<section>
|
||||
^{examAutoOccurrenceCalculateWidget tid ssh csh examn}
|
||||
<section>
|
||||
$if computedValues
|
||||
^{computedValuesTip}
|
||||
|
||||
3
templates/exam/auto-occurrence-confirm.hamlet
Normal file
3
templates/exam/auto-occurrence-confirm.hamlet
Normal file
@ -0,0 +1,3 @@
|
||||
$newline never
|
||||
^{mappingWgt}
|
||||
^{confirmWidget}
|
||||
15
templates/widgets/exam-occurrence-mapping-description.hamlet
Normal file
15
templates/widgets/exam-occurrence-mapping-description.hamlet
Normal file
@ -0,0 +1,15 @@
|
||||
$newline never
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall desc <- descriptions
|
||||
<li>
|
||||
$case desc
|
||||
$of ExamOccurrenceMappingRange minChars maxChars
|
||||
$if doPrefix
|
||||
#{titleCase minChars}… – #{titleCase maxChars}…
|
||||
$else
|
||||
…#{titleCase minChars} – …#{titleCase maxChars}
|
||||
$of ExamOccurrenceMappingSpecial special
|
||||
$if doPrefix
|
||||
#{titleCase special}…
|
||||
$else
|
||||
…#{titleCase special}
|
||||
41
templates/widgets/exam-occurrence-mapping.hamlet
Normal file
41
templates/widgets/exam-occurrence-mapping.hamlet
Normal file
@ -0,0 +1,41 @@
|
||||
$newline never
|
||||
<table .table .table--striped .table--hover>
|
||||
<thead>
|
||||
<tr .table__row .table__row--head>
|
||||
<th .table__th>
|
||||
_{MsgExamRoomName}
|
||||
<th .table__th>
|
||||
_{MsgExamRoomLoad}
|
||||
$maybe rule <- occMappingRule
|
||||
$case rule
|
||||
$of ExamRoomSurname
|
||||
<th .table__th>
|
||||
_{MsgExamRoomMappingSurname}
|
||||
$of ExamRoomMatriculation
|
||||
<th .table__th>
|
||||
_{MsgExamRoomMappingMatriculation}
|
||||
$of _
|
||||
<th .table__td>
|
||||
<th .table__th>
|
||||
_{MsgExamRoom}
|
||||
<th .table__th>
|
||||
_{MsgExamRoomTime}
|
||||
<th .table__th>
|
||||
_{MsgExamRoomDescription}
|
||||
<tbody>
|
||||
$forall Entity occId ExamOccurrence{ examOccurrenceName, examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription, examOccurrenceCapacity } <- occurrences
|
||||
<tr .table__row>
|
||||
<td .table__td>
|
||||
_{examOccurrenceName}
|
||||
<td .table__td>
|
||||
_{loadProp (occLoad occId) examOccurrenceCapacity}
|
||||
$maybe mappingWgt <- occMapping occId
|
||||
<td .table__td>
|
||||
^{mappingWgt}
|
||||
<td .table__td>
|
||||
#{examOccurrenceRoom}
|
||||
<td .table__td>
|
||||
^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd}
|
||||
<td .table__td>
|
||||
$maybe desc <- examOccurrenceDescription
|
||||
#{desc}
|
||||
@ -505,6 +505,7 @@ fillDb = do
|
||||
, examGradingRule = Nothing
|
||||
, examBonusRule = Nothing
|
||||
, examOccurrenceRule = ExamRoomManual
|
||||
, examExamOccurrenceMapping = Nothing
|
||||
, examVisibleFrom = Just now
|
||||
, examRegisterFrom = Just now
|
||||
, examRegisterTo = Just $ addUTCTime (14 * nominalDay) now
|
||||
|
||||
Loading…
Reference in New Issue
Block a user