chore(tutorial): towards #2347 exam occurrence form added (WIP)

messages/uniworx/misc/de-de-formal.msg

@@ -36,3 +36,4 @@ NoProblem: Keine Probleme gefunden
 Unknown: ist unbekannt
 UnknownOrNotAllowed: ist unbekannt oder hier nicht erlaubt
 Ambiguous: ist uneindeutig
+Action: Aktion

messages/uniworx/misc/en-eu.msg

@@ -36,3 +36,4 @@ NoProblem: No Probleme found
 Unknown: is unknown
 UnknownOrNotAllowed: is unknown or not allowed here
 Ambiguous: is ambiguous
+Action: Action

src/Handler/Exam/Form.hs

@@ -7,6 +7,7 @@ module Handler.Exam.Form
   , ExamOccurrenceForm(..)
   , ExamPartForm(..)
   , examForm
+  , examOccurrenceMultiForm, examOccurrenceForm
   , examFormTemplate, examTemplate
   , validateExam
   ) where
@@ -137,7 +138,7 @@ examForm (Entity _ Course{..}) template csrf = hoist liftHandler $ do
     <*> aopt utcTimeField (fslpI MsgExamPartsFrom (mr MsgDate) & setTooltip MsgExamPartsFromTip) (efPartsFrom <$> template)
     <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip (bool MsgExamFinishedTip MsgExamFinishedTipCloseOnFinished $ is _ExamCloseOnFinished' schoolExamCloseMode)) (efFinished <$> template)
     <*  aformSection MsgExamFormOccurrences
-    <*> examOccurrenceForm (efOccurrences <$> template)
+    <*> examOccurrenceMultiForm (efOccurrences <$> template)
     <*  aformSection MsgExamFormAutomaticFunctions
     <*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True)
     <*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
@@ -250,24 +251,9 @@ examCorrectorsForm mPrev = wFormToAForm $ do
 
   fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgExamCorrectorsTip) False (Set.toList <$> mPrev)
 
-examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
-examOccurrenceForm prev = wFormToAForm $ do
-  currentRoute <- fromMaybe (error "examOccurrenceForm called from 404-handler") <$> getCurrentRoute
-  let
-    miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
-    miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
 
-  fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences) False $ Set.toList <$> prev
+examOccurrenceForm :: (Text -> Text) -> Maybe ExamOccurrenceForm -> Form ExamOccurrenceForm
-  where
+examOccurrenceForm nudge mPrev csrf = do
-    examinerField = knownUserField True $ Just $ E.from $ \usr -> do
-      E.where_ $
-        (E.exists . E.from $ \exCorr -> E.where_ $ exCorr E.^. ExamCorrectorUser          E.==.         usr E.^. UserId
-        ) E.||.
-        (E.exists . E.from $ \exOccr -> E.where_ $ exOccr E.^. ExamOccurrenceExaminer     E.==. E.just (usr E.^. UserId)
-        )
-      pure usr
-
-    examOccurrenceForm' nudge mPrev csrf = do
       (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
       (eofNameRes, eofNameView) <- mpreq (textField & cfStrip & cfCI) (fslI MsgExamRoomName & addName (nudge "name")) (eofName <$> mPrev)
       (eofExaminerRes, eofExaminerView) <- mopt examinerField (fslI MsgExamStaff & addName (nudge "examiner")) (eofExaminer <$> mPrev) -- TODO: restrict suggestions!
@@ -280,7 +266,6 @@ examOccurrenceForm prev = wFormToAForm $ do
       (eofStartRes, eofStartView) <- mpreq utcTimeField (fslI MsgExamRoomStart & addName (nudge "start")) (eofStart <$> mPrev)
       (eofEndRes, eofEndView) <- mopt utcTimeField (fslI MsgExamRoomEnd & addName (nudge "end")) (eofEnd <$> mPrev)
       (eofDescRes, eofDescView) <- mopt htmlField (fslI MsgExamRoomDescription & addName (nudge "description")) (eofDescription <$> mPrev)
-
       return ( ExamOccurrenceForm
                  <$> eofIdRes
                  <*> eofNameRes
@@ -293,16 +278,33 @@ examOccurrenceForm prev = wFormToAForm $ do
                  <*> eofDescRes
              , $(widgetFile "widgets/massinput/examRooms/form")
              )
+  where
+    examinerField = knownUserField True $ Just $ E.from $ \usr -> do
+      E.where_ $
+        (E.exists . E.from $ \exCorr -> E.where_ $ exCorr E.^. ExamCorrectorUser          E.==.         usr E.^. UserId
+        ) E.||.
+        (E.exists . E.from $ \exOccr -> E.where_ $ exOccr E.^. ExamOccurrenceExaminer     E.==. E.just (usr E.^. UserId)
+        )
+      pure usr
 
+examOccurrenceMultiForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
+examOccurrenceMultiForm prev = wFormToAForm $ do
+  currentRoute <- fromMaybe (error "examOccurrenceMultiForm called from 404-handler") <$> getCurrentRoute
+  let
+    miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
+    miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
+
+  fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences) False $ Set.toList <$> prev
+  where
     miAdd' nudge submitView csrf = do
       MsgRenderer mr <- getMsgRenderer
-      (res, formWidget) <- examOccurrenceForm' nudge Nothing csrf
+      (res, formWidget) <- examOccurrenceForm nudge Nothing csrf
       let
         addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
           | newDat `Set.member` oldDat -> FormFailure [mr MsgExamRoomAlreadyExists]
           | otherwise -> FormSuccess $ pure newDat
       return (addRes, $(widgetFile "widgets/massinput/examRooms/add"))
-    miCell' nudge dat = examOccurrenceForm' nudge (Just dat)
+    miCell' nudge dat = examOccurrenceForm nudge (Just dat)
     miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examRooms/layout")
     miIdent' :: Text
     miIdent' = "exam-occurrences"

src/Handler/Tutorial/Users.hs

@@ -16,6 +16,7 @@ import Handler.Utils
 import Handler.Utils.Course
 import Handler.Utils.Course.Cache
 import Handler.Utils.Tutorial
+import Handler.Exam.Form (examOccurrenceMultiForm, ExamOccurrenceForm(..))
 import Database.Persist.Sql (deleteWhereCount)
 
 import qualified Data.CaseInsensitive as CI
@@ -44,22 +45,28 @@ embedRenderMessage ''UniWorX ''GenTutAction id
 data GenTutActionData
   = GenTutActNoneData           -- Dummy action to hide form in a more natural way
   | GenTutActOccAddData
+      { -- gtaoaExam :: ExamId,
+        gtaoaOcc  :: Set ExamOccurrenceForm
+      }
   | GenTutActOccEditData
-  deriving (Eq, Ord, Read, Show, Generic)
+  deriving (Eq, Ord, Show, Generic)
 
 genTutActionMap ::(_ -> Text) -> Map GenTutAction (AForm Handler GenTutActionData)
 genTutActionMap _mr = Map.fromList
   [ (GenTutActNone
     , pure GenTutActNoneData )
-  , (GenTutActOccAdd
+  , (GenTutActOccAdd, GenTutActOccAddData
-    , pure GenTutActOccAddData )
+      <$> examOccurrenceMultiForm Nothing -- TODO
+    )
   , (GenTutActOccEdit
     , pure GenTutActOccEditData) -- TODO
   ]
 
 makeGenTutActionForm :: (_ -> Text) -> Form GenTutActionData
-makeGenTutActionForm mr html = flip (renderAForm FormStandard) html $ multiActionA (genTutActionMap mr) (fslI MsgGenTutActions) (Just GenTutActNone)
+makeGenTutActionForm mr html = flip (renderAForm FormStandard) html $ multiActionA (genTutActionMap mr) (fslI MsgAction) (Just GenTutActNone)
-
+-- TODO: Idee: MultiAction für jedes Exam, um so die einzelnen Occurrences zu markieren!
+--       Default muss auch entsprechend generiert werden, wenn keine Occurrences für den Tag existieren
+--       Im Form sollten die neuen markiert werden als ungespeichert! Generell wünschenswert für MassInput!
 
 data TutorialUserAction
   = TutorialUserAssignExam
@@ -166,7 +173,7 @@ postTUsersR tid ssh csh tutn = do
         letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers
         let mbAletter = anyone letters
         case mbAletter of
-          Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- TODO: better error message
+          Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- cannot really happen
           Just aletter -> do
             apcIdent <- letterApcIdent aletter encRcvr now
             let fName = letterFileName aletter
@@ -220,8 +227,8 @@ postTUsersR tid ssh csh tutn = do
     _other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
 
   case tcontent of
-    Just act -> act -- abort and return produced content
+    Just act -> act -- execute action and return produced content
-    Nothing -> do
+    Nothing -> do   -- no table action, continue normally
       tutors <- runDB $ E.select $ do
         (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
           `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId)
@@ -230,7 +237,7 @@ postTUsersR tid ssh csh tutn = do
 
       let mr :: (() -> Text) = const "TODO: message renderer for general tutorial action form" -- getMessageRender
       genTutActWgt <- do
-        ((_gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm FIDGeneralTutorialAction $ makeGenTutActionForm mr
+        ((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm FIDGeneralTutorialAction $ makeGenTutActionForm mr
         let gtaAnchor  = "general-tutorial-action-form" :: Text
             gtaRoute   = croute :#: gtaAnchor
             gtaForm    = wrapForm gtaWgt FormSettings
@@ -241,6 +248,11 @@ postTUsersR tid ssh csh tutn = do
                               , formSubmit = FormSubmit
                               , formAnchor = Just gtaAnchor
                               }
+        formResult gtaRes $ \case
+          GenTutActNoneData -> return ()
+          GenTutActOccAddData{} -> error "not yet implemended" -- TODO
+
+          GenTutActOccEditData{} -> error "not yet implemended" -- TODO
 
         -----------------------------------------------
         -- !!!!!TODO: evaluate form result !!!!!!!!! --

src/Handler/Utils/Form/MassInput.hs

@@ -323,12 +323,12 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
       runTwice act = do
         r <- ask
         s <- State.get
-        res1 <- fmap (view _1) . lift $ evalRWST (act Nothing) r s 
+        res1 <- fmap (view _1) . lift $ evalRWST (act Nothing) r s
         local (_1 .~ Nothing) . act $ Just res1
       replaceWithFirst :: forall k x y. Ord k => Maybe (Map k (x, y)) -> Map k (x, y) -> Map k (x, y)
       replaceWithFirst Nothing xs = xs
       replaceWithFirst (Just f) s = Map.unionWith (\(f1, _f2) (_s1, s2) -> (f1, s2)) f s
- 
+
   (shape, liveliness, delShapeUpdate, addResults, addResults', delResults, shapeChanged) <- runTwice $ \mPrev -> do
     let sentLiveliness' = maybe sentLiveliness (view _2) mPrev
 
@@ -567,7 +567,7 @@ massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequire
     doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
       where
         prevElems = Map.elems prevData
-        startKey = maybe 0 succ $ fst <$> Map.lookupMax prevData
+        startKey = maybe 0 (succ . fst) $ Map.lookupMax prevData
 
     miCell :: ListPosition -> cellData -> Maybe () -> (Text -> Text)
            -> (Markup -> MForm handler (FormResult (), Widget))
@@ -643,7 +643,7 @@ massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fReq
     doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
       where
         prevElems = Map.elems prevData
-        startKey = maybe 0 succ $ fst <$> Map.lookupMax prevData
+        startKey = maybe 0 (succ . fst) $ Map.lookupMax prevData
 
     miCell :: ListPosition -> cellData -> Maybe cellData -> (Text -> Text)
            -> (Markup -> MForm handler (FormResult cellData, Widget))

src/Utils/Set.hs

@@ -14,7 +14,7 @@ module Utils.Set
 , mapIntersectNotOne
 , set2NonEmpty
 , maybeInsert
-) where 
+) where
 
 import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.Set as Set
@@ -27,7 +27,7 @@ import Control.Lens
 
 
 -- | cardinal number of an intersection of a set and a list of sets
-setIntersectNotOne :: Ord a => Set a -> [Set a] -> Int 
+setIntersectNotOne :: Ord a => Set a -> [Set a] -> Int
 setIntersectNotOne _ [] = 0
 setIntersectNotOne k r = Set.size $ Set.intersection k others where others = Set.unions r
 
@@ -37,14 +37,14 @@ setIntersectNotOne k r = Set.size $ Set.intersection k others where others = Set
 
 -- | extracts from a map a list of values (sets) without one specific entry (a)
 getAllElemsWithoutOne :: (Ord a) => Map a (Set b) -> a -> [Set b]
-getAllElemsWithoutOne m cid = Map.elems $ Map.delete cid m 
+getAllElemsWithoutOne m cid = Map.elems $ Map.delete cid m
 
--- | transforms values (sets) of a map to integers. The number gives information about how many entreis are not only in this one 
+-- | transforms values (sets) of a map to integers. The number gives information about how many entreis are not only in this one
-mapIntersectNotOne :: forall a b. (Ord a, Ord b) => Map a (Set b) -> Map a Int 
+mapIntersectNotOne :: forall a b. (Ord a, Ord b) => Map a (Set b) -> Map a Int
-mapIntersectNotOne m = Map.mapWithKey f m where 
+mapIntersectNotOne m = Map.mapWithKey f m where
     f :: a -> Set b -> Int
     f k _ = setIntersectNotOne (Map.findWithDefault Set.empty k m) (getAllElemsWithoutOne m k)
- 
+
 --------------------------
 -- Functions from Utils --
 --------------------------
@@ -56,6 +56,7 @@ setIntersections (h:t) = foldl' Set.intersection h t
 
 setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b
 setMapMaybe f = Set.fromList . mapMaybe f . Set.toList
+-- setMapMaybe f = Set.foldr (maybeInsert . f) Set.empty        -- actually half as efficient as previous line using -O2
 
 -- | like `setMapMaybe`, but only when f is strictly increasing
 setMapMaybeMonotonic :: (a -> Maybe b) -> Set a -> Set b
@@ -75,7 +76,7 @@ setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList
 
 -- setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b)
 -- setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right)
--- 
+--
 setPartitionEithers :: Set (Either a b) -> (Set a, Set b)
 setPartitionEithers = (,) <$> setMapMaybeMonotonic (preview _Left) <*> setMapMaybeMonotonic (preview _Right)
 
@@ -88,5 +89,6 @@ set2NonEmpty _ (Set.toList -> h:t) = h NonEmpty.:| t
 set2NonEmpty d _ = d NonEmpty.:| []
 
 maybeInsert :: Ord a => Maybe a -> Set a -> Set a
+-- maybeInsert = flip (ap maybe (flip Set.insert))
 maybeInsert Nothing  = id
 maybeInsert (Just k) = Set.insert k