various minor code refactors

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

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

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

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

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