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| +