Buttons reworked after call; not yet working

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

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}
-            <button type=submit name=#{name} value=#{toPathPiece val} *{attrs} ##{id}>^{label val}
+            <button 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 = asum $ fst <$> resultWidgetMap
+  let result = case (asum $ fst <$> resultWidgetMap) of
+        FormSuccess (Just x) -> FormSuccess x
+        FormSuccess Nothing  -> FormMissing
+        _other                -> FormMissing
   let viewF = (Map.!) (snd <$> resultWidgetMap)
   
+  
   return (result, viewF)
 
 ----------------------------

templates/home.hamlet

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

templates/submission-list.hamlet

@@ -3,4 +3,4 @@
 
 <form method=POST enctype=#{selectEncoding} target=_blank action=@{SubmissionDownloadMultiArchiveR}>
   ^{submissionTable}
-  <button type=submit >Markierte herunterladen
+  <button .btn .btn-default type=submit >Markierte herunterladen