diff --git a/src/Handler/Schedule.hs b/src/Handler/Schedule.hs index e1918784e..b740f28ad 100644 --- a/src/Handler/Schedule.hs +++ b/src/Handler/Schedule.hs @@ -33,11 +33,11 @@ postScheduleR = do scheduleOptionsForm :: Html -> MForm (HandlerFor UniWorX) (FormResult ScheduleOptions, Widget) scheduleOptionsForm csrf = do (viewRess, viewWidgets) <- fmap unzip . for (universeF :: [ScheduleView]) $ \sView -> - mopt (buttonField ScheduleOptions - { scheduleView = sView - , scheduleOffset = ScheduleOffsetNone - , scheduleOptionsAction = ScheduleSetView - }) + mopt (buttonFieldNoParse ScheduleOptions + { scheduleView = sView + , scheduleOffset = ScheduleOffsetNone + , scheduleOptionsAction = ScheduleSetView + }) ("" { fsName = Just $ toPathPiece GetScheduleOptions , fsAttrs = if sView == scheduleView currentScheduleOptions then [("disabled","")] else mempty }) Nothing @@ -74,9 +74,9 @@ postScheduleR = do _ -> mempty (offsetRess, offsetWidgets) <- fmap unzip . for offsetBtns $ \btn -> - mopt (buttonField btn) ("" { fsName = Just $ toPathPiece GetScheduleOptions - , fsAttrs = if offsetInDays (scheduleOffset btn) == offsetInDays (scheduleOffset currentScheduleOptions) then [("disabled","")] else mempty - }) Nothing + mopt (buttonFieldNoParse btn) ("" { fsName = Just $ toPathPiece GetScheduleOptions + , fsAttrs = if offsetInDays (scheduleOffset btn) == offsetInDays (scheduleOffset currentScheduleOptions) then [("disabled","")] else mempty + }) Nothing offsetRes <- if -- TODO: ignoring FormFailures for now -- | Just errs <- fromNullable (filter (is _FormFailure) offsetRess) -> do diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 95d197cf9..f43651cfd 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -332,6 +332,27 @@ buttonField btn = Field{..} | otherwise = return . Left $ SomeMessage MsgWrongButtonValue fieldParse _ _ = return . Left $ SomeMessage MsgMultipleButtonValues +-- | Similar to buttonField, but with dummy fieldParse +buttonFieldNoParse :: forall a m. + ( Button (HandlerSite m) a + , MonadHandler m + ) => a -> Field m a +buttonFieldNoParse btn = Field{..} + where + fieldEnctype = UrlEncoded + + fieldView :: FieldViewFunc m a + fieldView fid name attrs _val _ = let + validate = btnValidate (Proxy @(HandlerSite m)) btn + classes :: [ButtonClass (HandlerSite m)] + classes = btnClasses btn + in [whamlet| + $newline never +