From 4bcbf963f192389a9d9ede1938f74f703413779d Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Wed, 15 Nov 2017 18:04:32 +0100
Subject: [PATCH] Button CSS style added.

---
 src/Foundation.hs         |  2 +-
 src/Handler/Home.hs       |  5 +++++
 src/Handler/Utils/Form.hs | 26 ++++++++++++++++++--------
 3 files changed, 24 insertions(+), 9 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index 67e9a8933..9d4e1a3c3 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -60,7 +60,7 @@ data MenuItem = MenuItem
     }
 
 data MenuTypes
-    = NavbarLeft MenuItem
+    = NavbarLeft  MenuItem
     | NavbarRight MenuItem
 
 -- This is where we define all of the routes in our application. For a full
diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs
index a5363933f..be27e85b7 100644
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@@ -34,6 +34,11 @@ instance PathPiece CreateButton where    -- for displaying the button only, not
 instance Button CreateButton where
   label CreateMath = [whamlet|Ma<i>thema</i>tik|]
   label CreateInf  = "Informatik"  
+  
+  cssClass CreateMath = Info
+  cssClass CreateInf  = Primary
+  
+  
 -- END Button needed here 
 
 getHomeR :: Handler Html
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 798b4edfe..f7eabe3d3 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -10,7 +10,7 @@
 module Handler.Utils.Form where 
 
 import Import
--- import Data.Time
+import qualified Data.Char as Char
 import Handler.Utils.DateTime
 import Data.String (IsString(..))
 
@@ -27,26 +27,36 @@ import Yesod.Form.Bootstrap3
 -- Buttons (new version ) --
 ----------------------------
 
+data ButtonCssClass = Default | Primary | Success | Info | Warning | Danger | Link
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+bcc2txt :: ButtonCssClass -> Text
+bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> show bcc)
+
 class (Enum a, Bounded a, Ord a, PathPiece a) => Button a where
   label :: a -> Widget
   label = toWidget . toPathPiece
 
+  cssClass :: a -> ButtonCssClass
+  cssClass _ = Default
+  
 
 buttonField :: Button a => a -> Field Handler a
 buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
   where 
+    fieldEnctype = UrlEncoded
+    
+    fieldView fid name attrs _val _ = 
+      [whamlet|
+        <button .btn .#{bcc2txt $ cssClass btn} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
+      |]
+      
     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 fid name attrs _val _ = 
-      [whamlet|
-        <button .btn .btn-default type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
-      |]
-      
-    fieldEnctype = UrlEncoded
 
 -- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
 buttonForm :: (Button a) => Form a
@@ -68,7 +78,7 @@ buttonForm csrf = do
     accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
     accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
     accResult' (FormSuccess (Just x)) _ = FormSuccess x
-    accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Should Failure override Success?
+    accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success?
     accResult' (FormSuccess Nothing) x = x
     accResult' FormMissing _ = FormMissing
     accResult' (FormFailure errs) _ = FormFailure errs