fix: build
This commit is contained in:
Gregor Kleen
parent
14fa4b2832
commit
9fd95d181c
@ -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
|
||||
|
||||
@ -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`
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user