diff --git a/src/Foundation.hs b/src/Foundation.hs index 9d4e1a3c3..092cc5f1b 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index be27e85b7..82ea20ded 100644 --- a/src/Handler/Home.hs +++ b/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|Mathematik|] label CreateInf = "Informatik" - cssClass CreateMath = Info - cssClass CreateInf = Primary - - + cssClass CreateMath = BCInfo + cssClass CreateInf = BCPrimary -- END Button needed here getHomeR :: Handler Html diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index f7eabe3d3..ec1cdf069 100644 --- a/src/Handler/Utils/Form.hs +++ b/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} +