From d741dabc250ed04fb5161f8868f3c54f41a80377 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Thu, 19 Apr 2018 10:11:52 +0200
Subject: [PATCH] mforced & aforced

---
 src/Handler/Utils/Form.hs | 25 +++++++++++++++++++++++++
 1 file changed, 25 insertions(+)

diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 1c5c94f1e..665acff68 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 --
 ------------------------------------------------
@@ -426,3 +428,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