Pure button Forms working

src/Handler/Home.hs

@@ -32,15 +32,15 @@ instance PathPiece CreateButton where    -- for displaying the button only, not
   fromPathPiece = readFromPathPiece
   
 instance Button CreateButton where
-  label CreateMath = [whamlet|Mathematik|]
+  label CreateMath = [whamlet|Ma<i>thema</i>tik|]
   label CreateInf  = "Informatik"
   
 -- END Button needed here 
 
-
+{-  -- Old Version
 getHomeR :: Handler Html
 getHomeR = do 
-  (crBtnWdgt, crBtnEnctype) <- generateFormPost $ buttonForm 
+  (crBtnWdgt, crBtnEnctype) <- generateFormPost $ buttonFormOld
   defaultLayout $ do
     setTitle "Willkommen zum ReWorX Test!"
     $(widgetFile "home")
@@ -48,10 +48,30 @@ getHomeR = do
   
 postHomeR :: Handler Html 
 postHomeR = do
-  ((btnResult,_), _) <- runFormPost $ buttonForm 
+  ((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)
+  defaultLayout $ do
+    setTitle "Willkommen zum ReWorX Test!"
+    $(widgetFile "home")
+
+  
+postHomeR :: Handler Html 
+postHomeR = do
+  ((btnResult,_), _) <- runFormPost $ buttonForm  
+  case btnResult of 
+    (FormSuccess CreateInf)  -> setMessage "Informatik anlegen" 
+    (FormSuccess CreateMath) -> setMessage "Mathematik anlegen"
+    _other -> return ()    
+  getHomeR  
+  

src/Handler/Utils/Form.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -32,9 +33,55 @@ import Text.Blaze (Markup)
 class (Enum a, Bounded a, Ord a, PathPiece a) => Button a where
   label :: a -> Widget
   label = toWidget . toPathPiece
+
+
+buttonField :: Button a => a -> Field Handler a
+buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
+  where 
+    fieldParse []    _ = return $ Right Nothing
+    fieldParse [str] _ 
+      | str == toPathPiece btn = return $ Right $ Just btn
+      | otherwise  = return $ Left "Wrong button value"
+    fieldParse _ _ = return $ Left "Multiple button values"
+    
+    fieldView id name attrs _val _ = 
+      [whamlet|
+        <button .btn .btn-default type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{id}>^{label btn}
+      |]
+      
+    fieldEnctype = UrlEncoded
+
+-- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
+buttonForm :: (Button a) => Form a
+buttonForm csrf = do
+    buttonIdent <- newFormIdent
+    let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing  
+    (results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
+    let widget = do
+          [whamlet|
+            #{csrf}
+            $forall bView <- btnViews
+              ^{fvInput bView}
+          |]
+    return (accResult results,widget)
+  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 button parse"]
+    accResult' (FormSuccess (Just x)) _ = FormSuccess x
+    accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Should Failure override Success?
+    accResult' (FormSuccess Nothing) x = x
+    accResult' FormMissing _ = FormMissing
+    accResult' (FormFailure errs) _ = FormFailure errs
+
   
-buttonForm :: Button a => Markup -> MForm Handler (FormResult a, (a -> FieldView UniWorX))
+
-buttonForm html = do
+
+  
+buttonFormOld :: Button a => Markup -> MForm Handler (FormResult a, (a -> FieldView UniWorX))
+buttonFormOld html = do
   let 
     buttonValues = [minBound..maxBound] 
     buttonMap  = Map.fromList $ zip buttonValues buttonValues

src/Handler/Utils/Term.hs

@@ -13,14 +13,14 @@ import Model.Types
 -- import Data.Maybe
 
 
-termExistsField :: Field (HandlerT UniWorX IO) TermIdentifier
+termExistsField :: Field Handler TermIdentifier
 termExistsField = termField True
   -- TODO: Change this to an option list of active terms
 
-termNewField :: Field (HandlerT UniWorX IO) TermIdentifier
+termNewField :: Field Handler TermIdentifier
 termNewField = termField False 
 
-termField :: Bool -> Field (HandlerT UniWorX IO) TermIdentifier
+termField :: Bool -> Field Handler TermIdentifier
 termField mustexist = checkMMap checkTerm termToText textField
   where 
     errTextParse :: Text

templates/home.hamlet

@@ -65,10 +65,8 @@
 
                       <li .list-group-item>
                         Institut einmalig in Datenbank einfügen:
-                          <form .form-inline method=post action=@{HomeR} enctype=#{crBtnEnctype}>
+                          <form .form-inline method=post action=@{HomeR} enctype=#{btnEnctype}>
-                            ^{fvInput (crBtnWdgt CreateInf)}
+                            ^{btnWdgt}
-                          <form .form-inline method=post action=@{HomeR} enctype=#{crBtnEnctype}>
-                            ^{fvInput (crBtnWdgt CreateMath)}
                         
                       <li .list-group-item>
                         <a href=@{CourseEditR}>Kurse anlegen