diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs index 8d08e200e..df5377940 100644 --- a/src/Handler/Sheet/Form.hs +++ b/src/Handler/Sheet/Form.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wwarn #-} + module Handler.Sheet.Form ( SheetForm(..), SheetPersonalisedFilesForm(..), Loads , makeSheetForm @@ -77,149 +79,113 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS MaybeT . getEntity $ statementId return ((school, mSchoolAuthorshipStatement), course) sheetPersonalisedFilesForm <- makeSheetPersonalisedFilesForm $ template >>= sfPersonalF - flip (renderWForm FormStandard) html $ do - sfNameRes <- wreq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template) - sfDescriptionRes <- wopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template) - sfRequireExamRegistrationRes <- optionalActionW (apreq (examField Nothing cId) (fslI MsgSheetRequiredExam) (sfRequireExamRegistration =<< template)) (fslI MsgSheetRequireExam & setTooltip MsgSheetRequireExamTip) (is _Just . sfRequireExamRegistration <$> template) - wformSection MsgSheetFormFiles - sfSheetFRes <- wopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template) - sfHintFRes <- wopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template) - sfSolutionFRes <- wopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template) - sfMarkingFRes <- wopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles & setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template) - sfPersonalFRes <- optionalActionW sheetPersonalisedFilesForm (fslI MsgSheetPersonalisedFiles & setTooltip MsgSheetPersonalisedFilesTip) (is _Just . sfPersonalF <$> template) + let mkSheetForm + sfName + sfDescription + sfRequireExamRegistration + sfSheetF sfHintF sfSolutionF sfMarkingF + sfPersonalF sfVisibleFrom sfActiveFrom sfActiveTo sfHintFrom sfSolutionFrom + sfSubmissionMode sfGrouping sfType + sfAutoDistribute sfMarkingText sfAnonymousCorrection sfCorrectors + (sfAuthorshipStatementMode, sfAuthorshipStatementExam, sfAuthorshipStatement) + = SheetForm{..} - wformSection MsgSheetFormTimes - sfVisibleFromRes <- wopt utcTimeField (fslI MsgSheetVisibleFrom & setTooltip MsgSheetVisibleFromTip) ((sfVisibleFrom <$> template) <|> pure (Just ctime)) - sfActiveFromRes <- wopt utcTimeField (fslI MsgSheetActiveFrom & setTooltip MsgSheetActiveFromTip) (sfActiveFrom <$> template) - sfActiveToRes <- wopt utcTimeField (fslI MsgSheetActiveTo & setTooltip MsgSheetActiveToTip) (sfActiveTo <$> template) - sfHintFromRes <- wopt utcTimeField (fslpI MsgSheetHintFrom (mr MsgSheetHintFromPlaceholder) & setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template) - sfSolutionFromRes <- wopt utcTimeField (fslpI MsgSheetSolutionFrom (mr MsgSheetSolutionFromPlaceholder) & setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template) + flip (renderAForm FormStandard) html $ mkSheetForm + <$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template) + <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template) + <*> optionalActionA (apreq (examField Nothing cId) (fslI MsgSheetRequiredExam) (sfRequireExamRegistration =<< template)) (fslI MsgSheetRequireExam & setTooltip MsgSheetRequireExamTip) (is _Just . sfRequireExamRegistration <$> template) - wformSection MsgSheetFormType - sfSubmissionModeRes <- aFormToWForm . submissionModeForm $ (sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction False) - sfGroupingRes <- aFormToWForm $ sheetGroupAFormReq (fslI MsgSheetGroup) ((sfGrouping <$> template) <|> pure NoGroups) - sfTypeRes <- aFormToWForm $ sheetTypeAFormReq cId (fslI MsgSheetSheetType) (sfType <$> template) - sfAutoDistributeRes <- wpopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template) - sfMarkingTextRes <- wopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template) - sfAnonymousCorrectionRes <- wpopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template) - sfCorrectorsRes <- aFormToWForm . correctorForm $ maybe mempty sfCorrectors template + <* aformSection MsgSheetFormFiles + <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template) + <*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template) + <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template) + <*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles & setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template) + <*> optionalActionA sheetPersonalisedFilesForm (fslI MsgSheetPersonalisedFiles & setTooltip MsgSheetPersonalisedFilesTip) (is _Just . sfPersonalF <$> template) - let sfAuthorshipStatementExam' = sfAuthorshipStatementExam =<< template - sfAuthorshipStatement' = sfAuthorshipStatement =<< template - (sfAuthorshipStatementModeRes, sfAuthorshipStatementExamRes, sfAuthorshipStatementRes) - <- if | isn't _SchoolAuthorshipStatementModeNone schoolSheetAuthorshipStatementMode -> do - wformSection MsgSheetAuthorshipStatementSection + <* aformSection MsgSheetFormTimes + <*> aopt utcTimeField (fslI MsgSheetVisibleFrom & setTooltip MsgSheetVisibleFromTip) ((sfVisibleFrom <$> template) <|> pure (Just ctime)) + <*> aopt utcTimeField (fslI MsgSheetActiveFrom & setTooltip MsgSheetActiveFromTip) (sfActiveFrom <$> template) + <*> aopt utcTimeField (fslI MsgSheetActiveTo & setTooltip MsgSheetActiveToTip) (sfActiveTo <$> template) + <*> aopt utcTimeField (fslpI MsgSheetHintFrom (mr MsgSheetHintFromPlaceholder) & setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template) + <*> aopt utcTimeField (fslpI MsgSheetSolutionFrom (mr MsgSheetSolutionFromPlaceholder) & setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template) - let - reqContentField :: AForm Handler I18nStoredMarkup - reqContentField = formResultUnOpt mr' MsgSheetAuthorshipStatementContent - `fmapAForm` i18nFieldA htmlField True (\_ -> Nothing) ("authorship-statement" :: Text) - (fslI MsgSheetAuthorshipStatementContent) - True - ( fmap Just $ (sfAuthorshipStatement =<< template) - <|> (authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement) + <* aformSection MsgSheetFormType + <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction False)) + <*> sheetGroupAFormReq (fslI MsgSheetGroup) ((sfGrouping <$> template) <|> pure NoGroups) + <*> sheetTypeAFormReq cId (fslI MsgSheetSheetType) (sfType <$> template) + + <*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template) + <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template) + <*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template) + <*> correctorForm (maybe mempty sfCorrectors template) + + <*> let sfAuthorshipStatementExam' = sfAuthorshipStatementExam =<< template + sfAuthorshipStatement' = sfAuthorshipStatement =<< template + in wFormToAForm $ (\res -> (,,) <$> view _1 res <*> view _2 res <*> view _3 res) <$> + if | isn't _SchoolAuthorshipStatementModeNone schoolSheetAuthorshipStatementMode -> do + wformSection MsgSheetAuthorshipStatementSection + + let + reqContentField :: AForm Handler I18nStoredMarkup + reqContentField = formResultUnOpt mr' MsgSheetAuthorshipStatementContent + `fmapAForm` i18nFieldA htmlField True (\_ -> Nothing) ("authorship-statement" :: Text) + (fslI MsgSheetAuthorshipStatementContent) + True + ( fmap Just $ (sfAuthorshipStatement =<< template) + <|> (authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement) + ) + forcedContentField = wforced forcedAuthorshipStatementField (fslI MsgSheetAuthorshipStatementContent & setTooltip MsgSheetAuthorshipStatementContentForcedTip) + + if | not schoolSheetAuthorshipStatementAllowOther + -> (pure SheetAuthorshipStatementModeEnabled, pure sfAuthorshipStatementExam', ) + <$> fmap sequenceA (traverse forcedContentField $ authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement) + | otherwise -> do + examOpts <- + let examFieldQuery = E.from $ \exam -> do + E.where_ $ exam E.^. ExamCourse E.==. E.val cId + when (is _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode) $ + E.where_ . E.isJust $ exam E.^. ExamAuthorshipStatement + return exam + in liftHandler $ optionsCryptoIdE examFieldQuery examName + + let modeOpts = case schoolSheetAuthorshipStatementMode of + SchoolAuthorshipStatementModeNone -> Set.singleton SheetAuthorshipStatementModeDisabled + SchoolAuthorshipStatementModeOptional -> Set.fromList universeF + SchoolAuthorshipStatementModeRequired -> Set.fromList universeF + & Set.delete SheetAuthorshipStatementModeDisabled + & bool id (Set.delete SheetAuthorshipStatementModeExam) (hasn't (_olOptions . folded) examOpts) + modeOpts' = explainOptionList (optionsPathPiece . map (id &&& id) $ Set.toList modeOpts) $ \case + SheetAuthorshipStatementModeDisabled -> return $(i18nWidgetFile "sheet-authorship-statement-mode-tip/disabled") + SheetAuthorshipStatementModeExam -> return $(i18nWidgetFile "sheet-authorship-statement-mode-tip/exam") + SheetAuthorshipStatementModeEnabled -> return $(i18nWidgetFile "sheet-authorship-statement-mode-tip/enabled") + examField' = selectField' (Just $ SomeMessage MsgSheetAuthorshipStatementExamNone) . return $ entityKey <$> examOpts + examField'' :: AForm Handler (Maybe ExamId) + examField'' + | isn't _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode + = aopt examField' (fslI MsgSheetAuthorshipStatementExam) (sfAuthorshipStatementExam <$> template) + | otherwise + = Just <$> apreq examField' (fslI MsgSheetAuthorshipStatementExam) (sfAuthorshipStatementExam =<< template) + modeForms = flip Map.fromSet modeOpts $ \case + SheetAuthorshipStatementModeDisabled -> pure + ( SheetAuthorshipStatementModeDisabled + , sfAuthorshipStatementExam' + , sfAuthorshipStatement' ) - forcedContentField = wforced forcedAuthorshipStatementField (fslI MsgSheetAuthorshipStatementContent & setTooltip MsgSheetAuthorshipStatementContentForcedTip) - - if | not schoolSheetAuthorshipStatementAllowOther - -> (pure SheetAuthorshipStatementModeEnabled, pure sfAuthorshipStatementExam', ) - <$> fmap sequenceA (traverse forcedContentField $ authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement) - | otherwise -> do - examOpts <- - let examFieldQuery = E.from $ \exam -> do - E.where_ $ exam E.^. ExamCourse E.==. E.val cId - when (is _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode) $ - E.where_ . E.isJust $ exam E.^. ExamAuthorshipStatement - return exam - in liftHandler $ optionsCryptoIdE examFieldQuery examName + SheetAuthorshipStatementModeExam -> (SheetAuthorshipStatementModeExam,, ) + <$> examField'' + <*> pure sfAuthorshipStatement' + SheetAuthorshipStatementModeEnabled -> (SheetAuthorshipStatementModeEnabled, sfAuthorshipStatementExam', ) + <$> fmap Just reqContentField - let modeOpts = case schoolSheetAuthorshipStatementMode of - SchoolAuthorshipStatementModeNone -> Set.singleton SheetAuthorshipStatementModeDisabled - SchoolAuthorshipStatementModeOptional -> Set.fromList universeF - SchoolAuthorshipStatementModeRequired -> Set.fromList universeF - & Set.delete SheetAuthorshipStatementModeDisabled - & bool id (Set.delete SheetAuthorshipStatementModeExam) (hasn't (_olOptions . folded) examOpts) - modeOpts' = explainOptionList (optionsPathPiece . map (id &&& id) $ Set.toList modeOpts) $ \case - SheetAuthorshipStatementModeDisabled -> return $(i18nWidgetFile "sheet-authorship-statement-mode-tip/disabled") - SheetAuthorshipStatementModeExam -> return $(i18nWidgetFile "sheet-authorship-statement-mode-tip/exam") - SheetAuthorshipStatementModeEnabled -> return $(i18nWidgetFile "sheet-authorship-statement-mode-tip/enabled") - examField' = selectField' (Just $ SomeMessage MsgSheetAuthorshipStatementExamNone) . return $ entityKey <$> examOpts - examField'' :: AForm Handler (Maybe ExamId) - examField'' - | isn't _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode - = aopt examField' (fslI MsgSheetAuthorshipStatementExam) (sfAuthorshipStatementExam <$> template) - | otherwise - = Just <$> apreq examField' (fslI MsgSheetAuthorshipStatementExam) (sfAuthorshipStatementExam =<< template) - modeForms = flip Map.fromSet modeOpts $ \case - SheetAuthorshipStatementModeDisabled -> pure - ( SheetAuthorshipStatementModeDisabled - , sfAuthorshipStatementExam' - , sfAuthorshipStatement' - ) - SheetAuthorshipStatementModeExam -> (SheetAuthorshipStatementModeExam,, ) - <$> examField'' - <*> pure sfAuthorshipStatement' - SheetAuthorshipStatementModeEnabled -> (SheetAuthorshipStatementModeEnabled, sfAuthorshipStatementExam', ) - <$> fmap Just reqContentField + massage res = (view _1 <$> res, view _2 <$> res, view _3 <$> res) - massage res = (view _1 <$> res, view _2 <$> res, view _3 <$> res) - - massage <$> explainedMultiActionW modeForms modeOpts' (fslI MsgSheetAuthorshipStatementRequired & setTooltip (bool MsgSheetAuthorshipStatementRequiredTip MsgSheetAuthorshipStatementRequiredForcedTip $ is _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode)) (sfAuthorshipStatementMode <$> template) - | otherwise -> return - ( pure SheetAuthorshipStatementModeDisabled - , pure sfAuthorshipStatementExam' - , pure sfAuthorshipStatement' - ) - - return $ SheetForm - <$> sfNameRes - <*> sfDescriptionRes - <*> sfRequireExamRegistrationRes - <*> sfSheetFRes <*> sfHintFRes <*> sfSolutionFRes <*> sfMarkingFRes - <*> sfPersonalFRes - <*> sfVisibleFromRes - <*> sfActiveFromRes - <*> sfActiveToRes - <*> sfHintFromRes - <*> sfSolutionFromRes - <*> sfSubmissionModeRes - <*> sfGroupingRes - <*> sfTypeRes - <*> sfAutoDistributeRes - <*> sfMarkingTextRes - <*> sfAnonymousCorrectionRes - <*> sfCorrectorsRes - <*> sfAuthorshipStatementModeRes - <*> sfAuthorshipStatementExamRes - <*> sfAuthorshipStatementRes - - -- <*> let - -- reqContentField :: (FieldSettings UniWorX -> FieldSettings UniWorX) -> AForm Handler I18nStoredMarkup - -- reqContentField ttip = fmapAForm (formResultUnOpt mr' MsgSheetAuthorshipStatementContent) - -- $ i18nFieldA htmlField True (\_ -> Nothing) ("authorship-statement" :: Text) - -- (fslI MsgSheetAuthorshipStatementContent & ttip) - -- True - -- ( fmap Just $ (sfAuthorshipStatement =<< template) - -- <|> (authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement) - -- ) - -- forcedContentField = aforced forcedAuthorshipStatementField - -- (fslI MsgSheetAuthorshipStatementContent & setTooltip MsgSheetAuthorshipStatementContentForcedTip) - -- contentField ttipReq - -- | not schoolSheetAuthorshipStatementAllowOther - -- = traverse forcedContentField $ authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement - -- | otherwise - -- = Just <$> reqContentField ttipReq - -- in case schoolSheetAuthorshipStatementMode of - -- SchoolAuthorshipStatementModeNone -> pure Nothing -- suppress display of whole section incl. header - -- otherMode -> aformSection MsgSheetAuthorshipStatementSection - -- *> aformMessage authorshipStatementExamRelatedTipMsg - -- *> case otherMode of - -- SchoolAuthorshipStatementModeOptional -> optionalActionA (fmapAForm (formResultUnOpt mr' MsgSheetAuthorshipStatementContent) $ contentField id) - -- (fslI MsgSheetAuthorshipStatementRequired & setTooltip MsgSheetAuthorshipStatementRequiredTip) - -- (is _Just . sfAuthorshipStatement <$> template) - -- SchoolAuthorshipStatementModeRequired -> contentField $ setTooltip MsgSheetAuthorshipStatementRequiredForcedTip - -- _none -> pure Nothing + massage <$> explainedMultiActionW modeForms modeOpts' (fslI MsgSheetAuthorshipStatementRequired & setTooltip (bool MsgSheetAuthorshipStatementRequiredTip MsgSheetAuthorshipStatementRequiredForcedTip $ is _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode)) (sfAuthorshipStatementMode <$> template) + | otherwise -> return + ( pure SheetAuthorshipStatementModeDisabled + , pure sfAuthorshipStatementExam' + , pure sfAuthorshipStatement' + ) where makeSheetPersonalisedFilesForm :: Maybe SheetPersonalisedFilesForm -> MForm Handler (AForm Handler SheetPersonalisedFilesForm) makeSheetPersonalisedFilesForm template' = do diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 2c0815014..e1083bcc0 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1250,12 +1250,15 @@ warnValidation msg isValid = unless isValid $ addMessageI Warning msg -- Form Manipulation -- ----------------------- -aFormToWForm :: Monad m => AForm m a -> WForm m (FormResult a) -aFormToWForm = mapRWST mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm - where - mFormToWForm' f = do - ((a, vs), ints, enctype) <- lift f - writer ((a, ints, enctype), vs) +aFormToWForm :: (MonadHandler m, HandlerSite m ~ site) => AForm m a -> WForm m (FormResult a) +aFormToWForm = mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm + +mFormToWForm' :: (MonadHandler m, HandlerSite m ~ site) + => MForm m (a, [FieldView site]) + -> WForm m a +mFormToWForm' = mapRWST $ \f -> do + ((a, vs), ints, enctype) <- lift f + writer ((a, ints, enctype), vs) infixl 4 `fmapAForm`