diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs
index 22929e16d..6949cf94d 100644
--- a/src/Handler/Home.hs
+++ b/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|Mathematik|]
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
+
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 22e1cc88b..f6a569e9a 100644
--- a/src/Handler/Utils/Form.hs
+++ b/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|
+