diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index 2e278a5ba..4b3d2a2ff 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg @@ -63,5 +63,6 @@ TutorialParticipantsDayEdits day@Text: Kursteilnehmer-Tagesnotizen aktualisiert CheckEyePermitMissing: Sehtest oder Führerschein fehlen noch CheckEyePermitIncompatible: Sehtest und Führerschein passen nicht zusammen -GenTutActOccCopy: Prüfungstermine von früherem Kurs kopieren +GenTutActOccCopyLast: Prüfungstermine von früherem Kurs kopieren +GenTutActOccCopyWeek: Prüfungstermine von früherer Woche kopieren GenTutActOccEdit: Relevante Prüfungstermine bearbeiten diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index 3ce1cdc86..35440d821 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/messages/uniworx/categories/courses/tutorial/en-eu.msg @@ -64,5 +64,6 @@ TutorialParticipantsDayEdits day: course participant day notes updated for #{day CheckEyePermitMissing: Eye exam or driving permit missing CheckEyePermitIncompatible: Eye exam and driving permit are incompatible -GenTutActOccCopy: Copy exam occurrences from previous course +GenTutActOccCopyLast: Copy exam occurrences from previous course +GenTutActOccCopyWeek: Copy exam occurrences from course on previous week GenTutActOccEdit: Edit relevant exam occurrences diff --git a/src/Handler/Qualification/Edit.hs b/src/Handler/Qualification/Edit.hs index 32dc35dfa..f90c2cb43 100644 --- a/src/Handler/Qualification/Edit.hs +++ b/src/Handler/Qualification/Edit.hs @@ -62,7 +62,7 @@ mkQualificationForm ssh templ = identifyForm FIDQualificationEdit . validateForm aopt_natFieldI msg = aopt (natFieldI $ UniWorXMessages [SomeMessage msg, text2message " ", SomeMessage MsgMustBePositive]) (fslI msg) -- [ 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15] - reorderedQualification = $(permuteFun [ 1, 2, 3, 4, 5,10, 6, 8, 7,11,12,13, 9,14,15]) Qualification -- read reverse: at the 6th position, the 10th element should be placed + reorderedQualification = $(permuteFun [ 1, 2, 3, 4, 5,10, 6, 8, 7,11,12,13, 9,14,15]) Qualification -- == inversePermutation [1,2,3,4,5,7,9,8,13,6,10,11,12,14,15] validateQualificationEdit :: SchoolId -> FormValidator Qualification Handler () validateQualificationEdit ssh = do canonise diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 3629054bf..d522a03b2 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -68,7 +68,8 @@ data TutorialUserActionData -- non-table form for general tutorial actions data GenTutAction - = GenTutActOccCopy + = GenTutActOccCopyWeek + | GenTutActOccCopyLast | GenTutActOccEdit deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -77,10 +78,17 @@ nullaryPathPiece ''GenTutAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''GenTutAction id data GenTutActionData - = GenTutActOccCopyData { gtaExam :: ExamId } - | GenTutActOccEditData { gtaExamMb :: ExamId } + = GenTutActOccCopyWeekData { gtaExam :: ExamId } + | GenTutActOccCopyLastData { gtaExam :: ExamId } + | GenTutActOccEditData { gtaExam :: ExamId } deriving (Eq, Ord, Show, Generic) +gta2gtad :: GenTutAction -> ExamId -> GenTutActionData +gta2gtad GenTutActOccCopyWeek = GenTutActOccCopyWeekData +gta2gtad GenTutActOccCopyLast = GenTutActOccCopyLastData +gta2gtad GenTutActOccEdit = GenTutActOccEditData + + -- mkGenTutForm :: [Filter Exam] -> Form GenTutActionData -- mkGenTutForm fltr = renderAForm FormStandard maa -- where @@ -96,8 +104,7 @@ mkGenTutForm fltr html = do (actRes, actView) <- mreq (selectFieldList ((\a->(a,a)) <$> universeF)) (fslI MsgCourseExam) Nothing (exmRes, exmView) <- mreq (examFieldFilter (Just $ SomeMessage MsgMenuExamNew) fltr) (fslI MsgCourseExam) Nothing let res :: FormResult GenTutAction -> FormResult ExamId -> FormResult GenTutActionData - res (FormSuccess GenTutActOccCopy) (FormSuccess eid) = FormSuccess $ GenTutActOccCopyData eid - res (FormSuccess GenTutActOccEdit) (FormSuccess eid) = FormSuccess $ GenTutActOccEditData eid + res (FormSuccess gtao) (FormSuccess eid) = FormSuccess $ gta2gtad gtao eid res (FormFailure e1) (FormFailure e2) = FormFailure $ e1 <> e2 res (FormFailure e) _ = FormFailure e res _ (FormFailure e) = FormFailure e @@ -257,18 +264,20 @@ postTUsersR tid ssh csh tutn = do , formAnchor = Just gtaAnchor } formResult gtaRes $ \case - GenTutActOccEditData { gtaExamMb=eId } -> do + GenTutActOccEditData { gtaExam=eId } -> do Exam{examName=ename} <- runDBRead $ get404 eId redirect $ CTutorialR tid ssh csh tutn $ TExamR ename - GenTutActOccCopyData { gtaExam=eId } -> - case dbegin of - Nothing -> addMessageI Error MsgExamOccurrenceCopyNoStartDate - (Just dto) -> - let cfailure = addMessageI Error MsgExamOccurrenceCopyFail - csuccess n = addMessageI Success (MsgExamOccurrencesCopied n) >> reloadKeepGetParams croute - copyFrom dfrom = copyExamOccurrences eId dfrom dto <&> (toMaybe =<< (> 0)) - in maybeM cfailure csuccess $ - runDB $ firstJustM $ map copyFrom $ take 21 $ drop 1 [dto, pred dto..] + copyAction -> case dbegin of + Nothing -> addMessageI Error MsgExamOccurrenceCopyNoStartDate + (Just dto) -> + let cfailure = addMessageI Error MsgExamOccurrenceCopyFail + csuccess n = addMessageI Success (MsgExamOccurrencesCopied n) >> reloadKeepGetParams croute + copyFrom dfrom = copyExamOccurrences (gtaExam copyAction) dfrom dto <&> (toMaybe =<< (> 0)) + step_dto = case copyAction of + GenTutActOccCopyWeekData{} -> addDays (-7) dto + _ -> pred dto + in maybeM cfailure csuccess $ + runDB $ firstJustM $ map copyFrom $ take 69 $ drop 1 [dto, step_dto..] -- search for up to 2 months / 1 year backwards tutors <- runDBRead $ E.select do (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index 46629ad78..394f2ebb1 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -29,6 +29,16 @@ import qualified Data.Text as Text import Utils.PathPiece +-------------------- +-- Non-TH Helpers -- +-------------------- + +-- | Invert a permutation specified as a list of all numbers 1..n, each number occurring precisely once, i.e. sort l == [1..(length l)] +-- Useful for @permuteFun +inversePermutation :: [Int] -> [Int] +inversePermutation l = map snd . sortOn fst $ zip l [1..] + + ------------ -- Tuples -- ------------ @@ -149,7 +159,9 @@ with -- Functions -- --------------- -permuteFun :: [Int] -> ExpQ -- generic permutation of function arguments, i.e. $(permuteFun [2,1]) == flip -- list determins position where the argument comes from +-- | Generic permutation of function, i.e. $(permuteFun [2,1]) == flip +-- Note that the function is applied to the permuted arguments, so usually the inverted permutation is required (see @inversePermutation) +permuteFun :: [Int] -> ExpQ permuteFun perm = lamE pat rhs where pat = map varP $ fn:xs rhs = foldl appE (varE fn) $ map varE ps