pseudo-required fields

Fixes #207

src/Handler/Corrections.hs

@@ -250,7 +250,7 @@ data ActionCorrectionsData = CorrDownloadData
                            | CorrSetCorrectorData (Maybe UserId)
                            | CorrAutoSetCorrectorData SheetId
 
-correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) -> Handler TypedContent
+correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
 correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
   tableForm <- makeCorrectionsTable whereClause displayColumns psValidator
   ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
@@ -325,16 +325,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
     $(widgetFile "corrections")
 
 
-type ActionCorrections' = (ActionCorrections, MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget))
+type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
   
 downloadAction :: ActionCorrections'
 downloadAction = ( CorrDownload
-                 , return (pure CorrDownloadData, Nothing)
+                 , pure CorrDownloadData
                  )
 
 assignAction :: Either CourseId SheetId -> ActionCorrections'
 assignAction selId = ( CorrSetCorrector
-                     , over (mapped._2) Just $ do
+                     , wFormToAForm $ do
                          correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
                            E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
                            E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
@@ -348,14 +348,13 @@ assignAction selId = ( CorrSetCorrector
 
                          correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey
 
-                         ($ mempty) . renderAForm FormStandard . wFormToAForm $ do
+                         cId <- wpreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing
-                            cId <- wreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing
+                         fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
-                            fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
                      )
 
 autoAssignAction :: SheetId -> ActionCorrections'
 autoAssignAction shid = ( CorrAutoSetCorrector
-                        , return (pure $ CorrAutoSetCorrectorData shid, Nothing)
+                        , pure $ CorrAutoSetCorrectorData shid
                         )
 
 getCorrectionsR, postCorrectionsR :: Handler TypedContent

src/Handler/Utils/Form.hs

@@ -24,7 +24,7 @@ import Handler.Utils.Templates
 import Handler.Utils.DateTime
 import qualified Data.Time as Time
 
-import Import
+import Import hiding (cons)
 import qualified Data.Char as Char
 import Data.String (IsString(..))
 
@@ -359,13 +359,13 @@ sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler S
 sheetTypeAFormReq FieldSettings{..} template = formToAForm $ do
   let
     selOptions = Map.fromList
-      [ ( Bonus', renderAForm' $ Bonus <$> maxPointsReq )
+      [ ( Bonus', Bonus <$> maxPointsReq )
-      , ( Normal', renderAForm' $ Normal <$> maxPointsReq )
+      , ( Normal', Normal <$> maxPointsReq )
-      , ( Pass', renderAForm' $ Pass
+      , ( Pass', Pass
           <$> maxPointsReq
-          <*> areq pointsField (fslpI MsgSheetTypePassingPoints "Punkte" & noValidate) (preview _passingPoints =<< template)
+          <*> apreq pointsField (fslpI MsgSheetTypePassingPoints "Punkte" & noValidate) (preview _passingPoints =<< template)
         )
-      , ( NotGraded', return (FormSuccess NotGraded, Nothing) )
+      , ( NotGraded', pure NotGraded )
       ]
   (res, selView) <- multiAction selOptions (classify' <$> template)
 
@@ -386,9 +386,7 @@ sheetTypeAFormReq FieldSettings{..} template = formToAForm $ do
     ])
 
   where
-    renderAForm' = fmap (over _2 Just) . ($ mempty) . renderAForm FormStandard
+    maxPointsReq = apreq pointsField (fslpI MsgSheetTypeMaxPoints "Punkte" & noValidate) (preview _maxPoints =<< template)
-
-    maxPointsReq = areq pointsField (fslpI MsgSheetTypeMaxPoints "Punkte" & noValidate) (preview _maxPoints =<< template)
     
     classify' :: SheetType -> SheetType'
     classify' = \case
@@ -401,11 +399,11 @@ sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler
 sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
   let
     selOptions = Map.fromList
-      [ ( Arbitrary', renderAForm' $ Arbitrary
+      [ ( Arbitrary', Arbitrary
-          <$> areq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
+          <$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
         )
-      , ( RegisteredGroups', return (FormSuccess RegisteredGroups, Nothing) )
+      , ( RegisteredGroups', pure RegisteredGroups )
-      , ( NoGroups', return (FormSuccess NoGroups, Nothing) )
+      , ( NoGroups', pure NoGroups )
       ]
   (res, selView) <- multiAction selOptions (classify' <$> template)
 
@@ -426,8 +424,6 @@ sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
     ])
 
   where
-    renderAForm' = fmap (over _2 Just) . ($ mempty) . renderAForm FormStandard
-    
     classify' :: SheetGroup -> SheetGroup'
     classify' = \case
       Arbitrary _ -> Arbitrary'
@@ -545,8 +541,21 @@ aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m
         => Field m a -> FieldSettings site -> a -> AForm m a
 aforced field settings val = formToAForm $ second pure <$> mforced field settings val
 
+apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe a -> AForm m a
+-- ^ Pseudo required
+apreq f fs mx = formToAForm $ do
+  mr <- getMessageRender
+  fmap (over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } ))) $ mopt f fs (Just <$> mx)
+
+wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
+wpreq f fs mx = mFormToWForm $ do
+  mr <- getMessageRender
+  fmap (over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } )) $ mopt f fs (Just <$> mx)
+
 multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
-            => Map action (MForm (HandlerT UniWorX IO) (FormResult a, Maybe Widget))
+            => Map action (AForm (HandlerT UniWorX IO) a)
             -> Maybe action
             -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
 multiAction acts defAction = do
@@ -554,7 +563,12 @@ multiAction acts defAction = do
   let
     options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
   (actionRes, actionView) <- mreq (selectField $ return options) "" defAction
-  results <- sequence acts
+  results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
-  let actionWidgets = Map.foldrWithKey (\act -> \case (_, Just w) -> ($(widgetFile "widgets/multiAction") :); (_, Nothing) -> id) [] results
+  let mToWidget (_, []) = return Nothing
+      mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty
+  widgets <- mapM mToWidget results
+  let actionWidgets = Map.foldrWithKey accWidget [] widgets
+      accWidget act Nothing = id
+      accWidget act (Just w) = cons $(widgetFile "widgets/multiAction")
       actionResults = Map.map fst results
   return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect"))