Minor changes to buttons

src/Foundation.hs

@@ -127,6 +127,11 @@ instance Yesod UniWorX where
                     , menuItemRoute = ProfileR
                     , menuItemAccessCallback = isJust muser
                     }
+                , NavbarLeft $ MenuItem
+                    { menuItemLabel = "Kurse"
+                    , menuItemRoute = CourseListR
+                    , menuItemAccessCallback = True
+                    }                    
                 , NavbarRight $ MenuItem
                     { menuItemLabel = "Login"
                     , menuItemRoute = AuthR LoginR

src/Handler/Home.hs

@@ -15,7 +15,7 @@ import Handler.Utils
 import Data.Time
 import qualified Data.Text as T
 import Yesod.Form.Bootstrap3 
-
+ 
 import Web.PathPieces (showToPathPiece, readFromPathPiece)
 
 import Colonnade
@@ -35,10 +35,8 @@ instance Button CreateButton where
   label CreateMath = [whamlet|Ma<i>thema</i>tik|]
   label CreateInf  = "Informatik"  
   
-  cssClass CreateMath = Info
-  cssClass CreateInf  = Primary
-  
-  
+  cssClass CreateMath = BCInfo
+  cssClass CreateInf  = BCPrimary  
 -- END Button needed here 
 
 getHomeR :: Handler Html

src/Handler/Utils/Form.hs

@@ -22,23 +22,42 @@ import qualified Data.Text as T
 import Yesod.Form.Functions (parseHelper)
 import Yesod.Form.Bootstrap3 
 
+import Web.PathPieces (showToPathPiece, readFromPathPiece)
+
+
 
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------
 
-data ButtonCssClass = Default | Primary | Success | Info | Warning | Danger | Link
+data ButtonCssClass = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
 
-bcc2txt :: ButtonCssClass -> Text
-bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> show bcc)
+bcc2txt :: ButtonCssClass -> Text -- a Hack; maybe define Read/Show manually
+bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> (drop 2 $ 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
+  cssClass _ = BCDefault
+  
+data StandardButton = BtnDelete | BtnAbort | BtnSave
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+  
+instance PathPiece StandardButton where    -- for displaying the button only, not really for paths
+  toPathPiece   = showToPathPiece
+  fromPathPiece = readFromPathPiece
+
+instance Button StandardButton where
+  label BtnDelete = "Löschen"
+  label BtnAbort  = "Abbrechen"
+  label BtnSave   = "Speichern"
+  
+  cssClass BtnDelete = BCWarning
+  cssClass BtnAbort  = BCDefault
+  cssClass BtnSave   = BCPrimary
   
 
 buttonField :: Button a => a -> Field Handler a
@@ -57,6 +76,43 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
       | otherwise  = return $ Left "Wrong button value"
     fieldParse _ _ = return $ Left "Multiple button values"
     
+    
+combinedButtonField1 :: Button a => [a] -> AForm Handler [Maybe a]
+combinedButtonField1 btns = traverse b2f btns
+  where
+    b2f b = aopt (buttonField b) "n/a" Nothing 
+
+    {-
+combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
+combinedButtonField btns inner csrf = do
+    buttonIdent <- newFormIdent
+    let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing  
+    (results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
+    (innerRes,innerWdgt) <- inner
+    let widget = do 
+          [whamlet|
+            #{csrf}
+            ^{innerWdgt}
+            <div .btn-group>
+              $forall bView <- btnViews
+                ^{fvInput bView}
+          |]
+    let result = case (accResult result, innerRes) of
+                    (FormSuccess b, FormSuccess i) -> FormSuccess (b,i)
+                    _ -> FormFailure ["Something went wrong"] -- TODO
+    return (result,widget)
+  where
+    accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
+    accResult = Foldable.foldr accResult' FormMissing
+
+    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? Shouldn't Failure override Success?
+    accResult' (FormSuccess Nothing) x = x
+    accResult' FormMissing _ = FormMissing
+    accResult' (FormFailure errs) _ = FormFailure errs       
+    -}
 
 -- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
 buttonForm :: (Button a) => Form a