Button Stubs

src/Foundation.hs

@@ -139,10 +139,10 @@ instance Yesod UniWorX where
                     }
                 ]
 
-        let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems]
+        let navbarLeftMenuItems  = [x | NavbarLeft  x <- menuItems]
         let navbarRightMenuItems = [x | NavbarRight x <- menuItems]
 
-        let navbarLeftFilteredMenuItems = [x | x <- navbarLeftMenuItems, menuItemAccessCallback x]
+        let navbarLeftFilteredMenuItems  = [x | x <- navbarLeftMenuItems , menuItemAccessCallback x]
         let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x]
 
         -- We break up the default layout into two components:

src/Handler/Utils/Form.hs

@@ -10,6 +10,8 @@ module Handler.Utils.Form where
 
 import Import
 -- import Data.Time
+import Data.Proxy
+import qualified Data.Map as Map
 import Handler.Utils.DateTime
 import Data.String (IsString(..))
 
@@ -19,10 +21,73 @@ import qualified Data.Text as T
 import Yesod.Form.Functions (parseHelper)
 import Yesod.Form.Bootstrap3 
 
+import Web.PathPieces (showToPathPiece, readFromPathPiece)
+import Text.Blaze (Markup)
+----------------------------
+-- Buttons (new version ) --
+----------------------------
 
--------------
--- Buttons --
--------------
+class (Enum a, Bounded 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
+  let 
+    buttonValues = [(minBound `asProxyTypeOf` btn)..maxBound] 
+    buttonMap  = Map.fromList $ zip buttonValues buttonValues
+    button val = Field parse view UrlEncoded
+      where
+        parse []    _ = return $ Right Nothing
+        parse [str] _ 
+          | str == toPathPiece val = return $ Right $ Just val
+          | otherwise = return $ Left "Wrong button value"
+        parse _ _ = return $ Left "Multiple button values"
+        
+        view id name attrs val _ = do
+          [whamlet|
+            #{html}
+            <button type=submit name=#{name} value=#{toPathPiece val} *{attrs} ##{id}>^{label val}
+          |]
+  
+  buttonIdent <- newFormIdent
+  resultWidgetMap <- forM buttonMap $ \val -> mopt (button val) ("" { fsName = Just buttonIdent }) Nothing
+  
+  let result = asum $ fst <$> resultWidgetMap
+  let viewF = (Map.!) (snd <$> resultWidgetMap)
+  
+  return (result, viewF)
+
+----------------------------
+-- Buttons (old version ) --
+----------------------------
 
 formBtnSave  :: (Text,Text,Text)
 formBtnSave   = ("save"  ,"Speichern"  ,"btn-primary")