diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index 1d66c6c5c..6bc384490 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index ea3957c50..14a75bfc2 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/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 \ No newline at end of file diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 62ba159c0..ba98c1e19 100644 --- a/src/Handler/Exam/Form.hs +++ b/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 - 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 - - examOccurrenceForm' nudge mPrev csrf = do +examOccurrenceForm :: (Text -> Text) -> Maybe ExamOccurrenceForm -> Form ExamOccurrenceForm +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" diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 421947221..31a4167b7 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/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 - , pure GenTutActOccAddData ) + , (GenTutActOccAdd, 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 - Nothing -> do + Just act -> act -- execute action and return produced content + 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 !!!!!!!!! -- diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 7e5d5e7dd..91b88a5a9 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/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)) diff --git a/src/Utils/Set.hs b/src/Utils/Set.hs index f895cd098..b51a0a24c 100644 --- a/src/Utils/Set.hs +++ b/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 -mapIntersectNotOne :: forall a b. (Ord a, Ord b) => Map a (Set b) -> Map a Int -mapIntersectNotOne m = Map.mapWithKey f m where +-- | 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 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 \ No newline at end of file