fix: build

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
+    let mkSheetForm 
-      sfSheetFRes <- wopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
+          sfName
-      sfHintFRes <- wopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template)
+          sfDescription
-      sfSolutionFRes <- wopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
+          sfRequireExamRegistration
-      sfMarkingFRes <- wopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles & setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
+          sfSheetF sfHintF sfSolutionF sfMarkingF
-      sfPersonalFRes <- optionalActionW sheetPersonalisedFilesForm (fslI MsgSheetPersonalisedFiles & setTooltip MsgSheetPersonalisedFilesTip) (is _Just . sfPersonalF <$> template)
+          sfPersonalF sfVisibleFrom sfActiveFrom sfActiveTo sfHintFrom sfSolutionFrom
+          sfSubmissionMode sfGrouping sfType
+          sfAutoDistribute sfMarkingText sfAnonymousCorrection sfCorrectors
+          (sfAuthorshipStatementMode, sfAuthorshipStatementExam, sfAuthorshipStatement)
+            = SheetForm{..}
 
-      wformSection MsgSheetFormTimes
+    flip (renderAForm FormStandard) html $ mkSheetForm
-      sfVisibleFromRes <- wopt utcTimeField (fslI MsgSheetVisibleFrom & setTooltip MsgSheetVisibleFromTip) ((sfVisibleFrom <$> template) <|> pure (Just ctime))
+      <$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template)
-      sfActiveFromRes <- wopt utcTimeField (fslI MsgSheetActiveFrom & setTooltip MsgSheetActiveFromTip) (sfActiveFrom <$> template)
+      <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
-      sfActiveToRes <- wopt utcTimeField (fslI MsgSheetActiveTo & setTooltip MsgSheetActiveToTip) (sfActiveTo <$> template)
+      <*> optionalActionA (apreq (examField Nothing cId) (fslI MsgSheetRequiredExam) (sfRequireExamRegistration =<< template)) (fslI MsgSheetRequireExam & setTooltip MsgSheetRequireExamTip) (is _Just . sfRequireExamRegistration <$> template)
-      sfHintFromRes <- wopt utcTimeField (fslpI MsgSheetHintFrom (mr MsgSheetHintFromPlaceholder) & setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template)
-      sfSolutionFromRes <- wopt utcTimeField (fslpI MsgSheetSolutionFrom (mr MsgSheetSolutionFromPlaceholder) & setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template)
 
-      wformSection MsgSheetFormType
+      <*  aformSection MsgSheetFormFiles
-      sfSubmissionModeRes <- aFormToWForm . submissionModeForm $ (sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction False)
+      <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
-      sfGroupingRes <- aFormToWForm $ sheetGroupAFormReq (fslI MsgSheetGroup) ((sfGrouping <$> template) <|> pure NoGroups)
+      <*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template)
-      sfTypeRes <- aFormToWForm $ sheetTypeAFormReq cId (fslI MsgSheetSheetType) (sfType <$> template)
+      <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
-      sfAutoDistributeRes <- wpopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
+      <*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles & setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
-      sfMarkingTextRes <- wopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
+      <*> optionalActionA sheetPersonalisedFilesForm (fslI MsgSheetPersonalisedFiles & setTooltip MsgSheetPersonalisedFilesTip) (is _Just . sfPersonalF <$> template)
-      sfAnonymousCorrectionRes <- wpopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template)
-      sfCorrectorsRes <- aFormToWForm . correctorForm $ maybe mempty sfCorrectors template
 
-      let sfAuthorshipStatementExam' = sfAuthorshipStatementExam =<< template
+      <*  aformSection MsgSheetFormTimes
-          sfAuthorshipStatement' = sfAuthorshipStatement =<< template
+      <*> aopt utcTimeField (fslI MsgSheetVisibleFrom & setTooltip MsgSheetVisibleFromTip) ((sfVisibleFrom <$> template) <|> pure (Just ctime))
-      (sfAuthorshipStatementModeRes, sfAuthorshipStatementExamRes, sfAuthorshipStatementRes)
+      <*> aopt utcTimeField (fslI MsgSheetActiveFrom & setTooltip MsgSheetActiveFromTip) (sfActiveFrom <$> template)
-        <- if | isn't _SchoolAuthorshipStatementModeNone schoolSheetAuthorshipStatementMode -> do
+      <*> aopt utcTimeField (fslI MsgSheetActiveTo & setTooltip MsgSheetActiveToTip) (sfActiveTo <$> template)
-                  wformSection MsgSheetAuthorshipStatementSection
+      <*> aopt utcTimeField (fslpI MsgSheetHintFrom (mr MsgSheetHintFromPlaceholder) & setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template)
+      <*> aopt utcTimeField (fslpI MsgSheetSolutionFrom (mr MsgSheetSolutionFromPlaceholder) & setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template)
 
-                  let 
+      <*  aformSection MsgSheetFormType
-                    reqContentField :: AForm Handler I18nStoredMarkup
+      <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction False))
-                    reqContentField = formResultUnOpt mr' MsgSheetAuthorshipStatementContent
+      <*> sheetGroupAFormReq (fslI MsgSheetGroup) ((sfGrouping <$> template) <|> pure NoGroups)
-                          `fmapAForm` i18nFieldA htmlField True (\_ -> Nothing) ("authorship-statement" :: Text)
+      <*> sheetTypeAFormReq cId (fslI MsgSheetSheetType) (sfType <$> template)
-                                      (fslI MsgSheetAuthorshipStatementContent)
+
-                                      True
+      <*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
-                                      ( fmap Just $     (sfAuthorshipStatement =<< template)
+      <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
-                                                    <|> (authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement)
+      <*> 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)
+                                    SheetAuthorshipStatementModeExam -> (SheetAuthorshipStatementModeExam,, )
+                                      <$> examField''
+                                      <*> pure sfAuthorshipStatement'
+                                    SheetAuthorshipStatementModeEnabled -> (SheetAuthorshipStatementModeEnabled, sfAuthorshipStatementExam', )
+                                      <$> fmap Just reqContentField
 
-                  if | not schoolSheetAuthorshipStatementAllowOther
+                                  massage res = (view _1 <$> res, view _2 <$> res, view _3 <$> res)
-                       -> (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
+                              massage <$> explainedMultiActionW modeForms modeOpts' (fslI MsgSheetAuthorshipStatementRequired & setTooltip (bool MsgSheetAuthorshipStatementRequiredTip MsgSheetAuthorshipStatementRequiredForcedTip $ is _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode)) (sfAuthorshipStatementMode <$> template)
-                               SchoolAuthorshipStatementModeNone -> Set.singleton SheetAuthorshipStatementModeDisabled
+                   | otherwise -> return
-                               SchoolAuthorshipStatementModeOptional -> Set.fromList universeF
+                       ( pure SheetAuthorshipStatementModeDisabled
-                               SchoolAuthorshipStatementModeRequired -> Set.fromList universeF
+                       , pure sfAuthorshipStatementExam'
-                                 & Set.delete SheetAuthorshipStatementModeDisabled
+                       , pure sfAuthorshipStatement'
-                                 & 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 <$> 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
   where
     makeSheetPersonalisedFilesForm :: Maybe SheetPersonalisedFilesForm -> MForm Handler (AForm Handler SheetPersonalisedFilesForm)
     makeSheetPersonalisedFilesForm template' = do

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 :: (MonadHandler m, HandlerSite m ~ site) => AForm m a -> WForm m (FormResult a)
-aFormToWForm = mapRWST mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm
+aFormToWForm = mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm
-  where
+
-    mFormToWForm' f = do
+mFormToWForm' :: (MonadHandler m, HandlerSite m ~ site)
-      ((a, vs), ints, enctype) <- lift f
+              => MForm m (a, [FieldView site])
-      writer ((a, ints, enctype), vs)
+              -> WForm m a
+mFormToWForm' = mapRWST $ \f -> do
+  ((a, vs), ints, enctype) <- lift f
+  writer ((a, ints, enctype), vs)
 
 infixl 4 `fmapAForm`