Button form cleaning

src/Handler/Home.hs

@@ -33,31 +33,9 @@ instance PathPiece CreateButton where    -- for displaying the button only, not
   
 instance Button CreateButton where
   label CreateMath = [whamlet|Ma<i>thema</i>tik|]
-  label CreateInf  = "Informatik"
+  label CreateInf  = "Informatik"  
-  
 -- END Button needed here 
 
-{-  -- Old Version
-getHomeR :: Handler Html
-getHomeR = do 
-  (crBtnWdgt, crBtnEnctype) <- generateFormPost $ buttonFormOld
-  defaultLayout $ do
-    setTitle "Willkommen zum ReWorX Test!"
-    $(widgetFile "home")
-
-  
-postHomeR :: Handler Html 
-postHomeR = do
-  ((btnResult,_), _) <- runFormPost $ buttonFormOld
-  $(logDebug) $ tshow btnResult  
-  case btnResult of 
-    (FormSuccess CreateInf)  -> setMessage "Informatik anlegen" 
-    (FormSuccess CreateMath) -> setMessage "Mathematik anlegen"
-    _other -> return ()    
-  getHomeR
-  
- -}  
-
 getHomeR :: Handler Html
 getHomeR = do 
   (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton)
@@ -70,8 +48,8 @@ postHomeR :: Handler Html
 postHomeR = do
   ((btnResult,_), _) <- runFormPost $ buttonForm  
   case btnResult of 
-    (FormSuccess CreateInf)  -> setMessage "Informatik anlegen" 
+    (FormSuccess CreateInf)  -> setMessage "Informatik-Knopf gedrückt" 
-    (FormSuccess CreateMath) -> setMessage "Mathematik anlegen"
+    (FormSuccess CreateMath) -> setMessage "Knopf Mathematik erkannt"
     _other -> return ()    
   getHomeR  
   

src/Handler/Utils/Form.hs

@@ -11,8 +11,6 @@ module Handler.Utils.Form where
 
 import Import
 -- import Data.Time
-import Data.Proxy
-import qualified Data.Map as Map
 import Handler.Utils.DateTime
 import Data.String (IsString(..))
 
@@ -24,8 +22,7 @@ import qualified Data.Text as T
 import Yesod.Form.Functions (parseHelper)
 import Yesod.Form.Bootstrap3 
 
-import Web.PathPieces (showToPathPiece, readFromPathPiece)
+
-import Text.Blaze (Markup)
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------
@@ -44,9 +41,9 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
       | otherwise  = return $ Left "Wrong button value"
     fieldParse _ _ = return $ Left "Multiple button values"
     
-    fieldView id name attrs _val _ = 
+    fieldView fid name attrs _val _ = 
       [whamlet|
-        <button .btn .btn-default type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{id}>^{label btn}
+        <button .btn .btn-default type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
       |]
       
     fieldEnctype = UrlEncoded
@@ -77,50 +74,9 @@ buttonForm csrf = do
     accResult' (FormFailure errs) _ = FormFailure errs
 
   
-
+---------------------------------------
-
+-- Buttons (old version, deprecated) --
-  
+---------------------------------------
-buttonFormOld :: Button a => Markup -> MForm Handler (FormResult a, (a -> FieldView UniWorX))
-buttonFormOld html = do
-  let 
-    buttonValues = [minBound..maxBound] 
-    buttonMap  = Map.fromList $ zip buttonValues buttonValues
-    button b = Field parse view UrlEncoded
-      where
-        parse []    _ = return $ Right Nothing
-        parse [str] _ 
-          | str == toPathPiece b = return $ Right $ Just b
-          | otherwise = return $ Left "Wrong button value"
-        parse _ _ = return $ Left "Multiple button values"
-        
-        view id name attrs _val _ = do
-          [whamlet|
-            #{html}
-            <button .btn .btn-default type=submit name=#{name} value=#{toPathPiece b} *{attrs} ##{id}>^{label b}
-          |]
-  
-  buttonIdent <- newFormIdent
-  resultWidgetMap <- forM buttonMap $ \val -> mopt (button val) ("" { fsName = Just buttonIdent }) Nothing
-    
-  let result = accResult $ fst <$> Map.elems resultWidgetMap
-  let viewF = (Map.!) (snd <$> resultWidgetMap)
-  
-  return (result, viewF)
-  where
-    accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
-    accResult = Foldable.foldr accResult' FormMissing
-
-    accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
-    accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous parse"]
-    accResult' (FormSuccess (Just x)) _ = FormSuccess x
-    accResult' _ x@(FormSuccess _) = x
-    accResult' (FormSuccess Nothing) x = x
-    accResult' FormMissing _ = FormMissing
-    accResult' (FormFailure errs) _ = FormFailure errs
-  
-----------------------------
--- Buttons (old version ) --
-----------------------------
 
 formBtnSave  :: (Text,Text,Text)
 formBtnSave   = ("save"  ,"Speichern"  ,"btn-primary")
@@ -147,8 +103,7 @@ defaultFormActions =  [ formBtnDelete
                       ]
 
 -- Post-Buttons
--- postButtonForm :: MonadHandler m => 
+postButtonForm :: Text -> Form ()
---     Text -> Text.Blaze.Internal.Markup -> MForm m (FormResult (), WidgetT (HandlerSite m) IO ())
 postButtonForm lblId = identifyForm lblId buttonF
   where
     buttonF = renderBootstrap3 BootstrapInlineForm $ pure () <* bootstrapSubmit bProps