diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 1f954318c..9e20dcc92 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -40,6 +40,8 @@ import qualified Database.Esqueleto.Internal.Sql as E import qualified Data.Set as Set +import Control.Monad.Writer.Class + ------------------------------------------------ -- Unique Form Identifiers to avoid accidents -- ------------------------------------------------ @@ -425,3 +427,26 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do , optionInternalValue = key , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a)) }) cPairs + +mforced :: (site ~ HandlerSite m, MonadHandler m) + => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site) +mforced Field{..} FieldSettings{..} val = do + tell fieldEnctype + name <- maybe newFormIdent return fsName + theId <- lift $ maybe newIdent return fsId + mr <- getMessageRender + let fsAttrs' = fsAttrs <> [("disabled", "")] + return ( FormSuccess val + , FieldView + { fvLabel = toHtml $ mr fsLabel + , fvTooltip = toHtml <$> fmap mr fsTooltip + , fvId = theId + , fvInput = fieldView theId name fsAttrs' (Right val) False + , fvErrors = Nothing + , fvRequired = False + } + ) + +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