diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index d00d69ca8..22929e16d 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -16,33 +16,42 @@ import Data.Time import qualified Data.Text as T import Yesod.Form.Bootstrap3 +import Web.PathPieces (showToPathPiece, readFromPathPiece) + import Colonnade import Yesod.Colonnade import qualified Data.UUID.Cryptographic as UUID +-- BEGIN - Buttons needed only here +data CreateButton = CreateMath | CreateInf -- Dummy for Example + deriving (Enum, Eq, Ord, Bounded, Read, Show) + +instance PathPiece CreateButton where -- for displaying the button only, not really for paths + toPathPiece = showToPathPiece + fromPathPiece = readFromPathPiece + +instance Button CreateButton where + label CreateMath = [whamlet|Mathematik|] + label CreateInf = "Informatik" + +-- END Button needed here + getHomeR :: Handler Html -getHomeR = defaultLayout $ do - (crInfWdgt, crInfEnctype) <- generateFormPost $ postButtonForm "Informatik" - (crMatWdgt, crMatEnctype) <- generateFormPost $ postButtonForm "Mathematik" - setTitle "Willkommen zum ReWorX Test!" - $(widgetFile "home") +getHomeR = do + (crBtnWdgt, crBtnEnctype) <- generateFormPost $ buttonForm + defaultLayout $ do + setTitle "Willkommen zum ReWorX Test!" + $(widgetFile "home") postHomeR :: Handler Html postHomeR = do - ((infResult,_), _) <- runFormPost $ postButtonForm "Informatik" - ((matResult,_), _) <- runFormPost $ postButtonForm "Mathematik" - $(logDebug) $ tshow infResult - $(logDebug) $ tshow matResult - setMessage "ButtonTest" - case infResult of - (FormSuccess ()) -> setMessage "Informatik anlegen" -- does not work somehow - -- TODO runDB - _other -> return () - case matResult of - (FormSuccess ()) -> setMessage "Mathematik anlegen" - -- TODO runDB + ((btnResult,_), _) <- runFormPost $ buttonForm + $(logDebug) $ tshow btnResult + 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 b08062b94..2f68f1239 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -27,62 +27,39 @@ import Text.Blaze (Markup) -- Buttons (new version ) -- ---------------------------- -class (Enum a, Bounded a, PathPiece a) => Button a where +class (Enum a, Bounded a, Ord a, PathPiece a) => Button a where label :: a -> Widget label = toWidget . toPathPiece - -data CreateButton = CreateMath | CreateInf - deriving (Enum, Bounded, Read, Show) - -instance PathPiece CreateButton where - toPathPiece = showToPathPiece - fromPathPiece = readFromPathPiece - -instance Button CreateButton - - --- buttonForm :: (Monad m, Button a) => a -> Markup -> MForm m (FormResult (Maybe a), (a -> Widget)) --- buttonForm :: (Monad m, Button a) => a -> Markup -> MForm m (FormResult (Maybe a), (a -> WidgetT (HandlerSite m) IO ())) --- buttonForm :: (Monad m, Button a) => a -> MForm m a -{- Inference yields this monster: -buttonForm - :: (HandlerSite m ~ UniWorX, Ord k, Text.Blaze.ToMarkup a, - Button (Either Text k), MonadHandler m, Enum k, Bounded k, - PathPiece k) => - Data.Proxy.Proxy k - -> a - -> Control.Monad.Trans.RWS.Lazy.RWST - (Maybe (Env, FileEnv), HandlerSite m, [Lang]) - Enctype - Ints - m - (FormResult (Maybe k), k -> FieldView (HandlerSite m)) - -} -buttonForm btn html = do +buttonForm :: Button a => Markup -> MForm Handler (FormResult a, (a -> FieldView UniWorX)) +buttonForm html = do let - buttonValues = [(minBound `asProxyTypeOf` btn)..maxBound] + buttonValues = [minBound..maxBound] buttonMap = Map.fromList $ zip buttonValues buttonValues - button val = Field parse view UrlEncoded + button b = Field parse view UrlEncoded where parse [] _ = return $ Right Nothing parse [str] _ - | str == toPathPiece val = return $ Right $ Just val + | 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 + view id name attrs _val _ = do [whamlet| #{html} -