Merge branch 'formgroups' into 'master'

Form sections

See merge request !140

messages/uniworx/de.msg

@@ -355,6 +355,9 @@ TimeFormat: Uhrzeitformat
 DownloadFiles: Dateien automatisch herunterladen
 DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden).
 NotificationSettings: Erwünschte Benachrichtigungen
+FormNotifications: Benachrichtigungen
+FormBehaviour: Verhalten
+FormCosmetics: Oberfläche
 
 ActiveAuthTags: Aktivierte Authorisierungsprädikate
 

src/Handler/Admin.hs

@@ -54,6 +54,24 @@ emailTestForm = (,)
       SelFormatDate -> d
       SelFormatTime -> t
 
+makeDemoForm :: Int -> Form (Int,Bool,Double)
+makeDemoForm n = identifyForm "adminTestForm" $ \html -> do -- Important: used identForm instead!
+    (result, widget) <- flip (renderAForm FormStandard) html $ (,,)
+        <$> areq (minIntField n "Zahl") (fromString $ "Ganzzahl > " ++ show n) Nothing
+        <*  aformSection MsgFormBehaviour
+        <*> areq checkBoxField "Muss nächste Zahl größer sein?" (Just True)
+        <*> areq doubleField "Fliesskommazahl" Nothing
+        <*  submitButton
+    return $ case result of
+      FormSuccess fsres
+        | errorMsgs <- validateResult fsres
+        , not $ null errorMsgs -> (FormFailure errorMsgs, widget)
+      _otherwise -> (result, widget)
+  where
+    validateResult :: (Int,Bool,Double) -> [Text]
+    validateResult (i,True,d) | (fromIntegral i) >= d = [tshow d <> " ist nicht größer als " <> tshow i, "Zweite Fehlermeldung", "Dritte Fehlermeldung"]
+    validateResult _other = []
+
 
 getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
 getAdminTestR = postAdminTestR
@@ -81,10 +99,43 @@ postAdminTestR = do
           ^{emailWidget}
       |]
 
-  defaultLayout $
+
-    -- setTitle "Uni2work Admin Testpage"
+  let demoFormAction (_i,_b,_d) = addMessage Info "All ok."
+  ((demoResult, formWidget),formEnctype) <- runFormPost $ makeDemoForm 7
+  formResult demoResult demoFormAction
+  let actionUrl = AdminTestR
+  let showDemoResult = [whamlet|
+          $maybe (i,b,d) <- formResult' demoResult
+            Received values:
+              <ul>
+                <li>#{show i}
+                <li>#{show b}
+                <li>#{show d}
+          $nothing
+            No form values received, due to #
+            $# Using formResult' above means that we usually to not distinguish the following two cases here, sind formResult does this already:
+            $case demoResult
+              $of FormSuccess _
+                $# Already dealt with above, to showecase usage of formResult' as normally done.
+                success, which should not happen here.
+              $of FormMissing
+                Form data missing, probably empty.
+              $of FormFailure msgs
+                <ul>
+                  $forall m <- msgs
+                    <li>#{m}
+        |]
+
+  let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
+  siteLayout locallyDefinedPageHeading $ do
+  -- defaultLayout $ do
+    setTitle "Uni2work Admin Testpage"
     $(widgetFile "adminTest")
 
+    [whamlet|<h2>Formular Demonstration|]
+    $(widgetFile "formPage")
+    showDemoResult
+
 
 getAdminErrMsgR, postAdminErrMsgR :: Handler Html
 getAdminErrMsgR = postAdminErrMsgR

src/Handler/Course.hs

@@ -34,10 +34,10 @@ colCourse = sortable (Just "course") (i18nCell MsgCourse)
             anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
               [whamlet|#{display courseName}|]
 
-colCourseDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
+-- colCourseDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
-colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do
+-- colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do
-    course <- view $ _dbrOutput . _1 . _entityVal
+--     course <- view $ _dbrOutput . _1 . _entityVal
-    return $ courseCell course
+--     return $ courseCell course
 
 colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colDescription = sortable Nothing mempty
@@ -51,19 +51,19 @@ colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|]
 
-colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+-- colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
-colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
+-- colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
-          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> mappend
+--           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> mappend
-            ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
+--             ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
-            ( case courseDescription of
+--             ( case courseDescription of
-                Nothing      -> mempty
+--                 Nothing      -> mempty
-                (Just descr) -> cell
+--                 (Just descr) -> cell
-                  [whamlet|
+--                   [whamlet|
-                    $newline never
+--                     $newline never
-                    <div>
+--                     <div>
-                      ^{modal "Beschreibung" (Right $ toWidget descr)}
+--                       ^{modal "Beschreibung" (Right $ toWidget descr)}
-                  |]
+--                   |]
-            )
+--             )
 
 colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colTerm = sortable (Just "term") (i18nCell MsgTerm)
@@ -221,7 +221,8 @@ getTermSchoolCourseListR tid ssh = do
   muid <- maybeAuthId
   let colonnade = widgetColonnade $ mconcat
         [ dbRow
-        , colCShortDescr
+        , colCShort
+        , colDescription
         , colRegFrom
         , colRegTo
         , colMembers
@@ -244,7 +245,8 @@ getTermCourseListR tid = do
   muid <- maybeAuthId
   let colonnade = widgetColonnade $ mconcat
         [ dbRow
-        , colCShortDescr
+        , colCShort
+        , colDescription
         , colSchoolShort
         , colRegFrom
         , colRegTo

src/Handler/Home.hs

@@ -206,7 +206,8 @@ getDataProtR = -- do
 -- | Allgemeine Informationen
 getInfoR :: Handler TypedContent
 getInfoR = selectRep $ do
-    provideRep . defaultLayout $ do
+    let infoHeading = [whamlet|Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>|]
+    provideRep . siteLayout infoHeading $ do
       let features = $(widgetFile "featureList")
           gitInfo :: Text
           gitInfo  = $gitDescribe <> " (" <> $gitCommitDate <> ")"

src/Handler/Profile.hs

@@ -28,24 +28,54 @@ data SettingsForm = SettingsForm
 
 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
 makeSettingForm template = identForm FIDsettings $ \html -> do
-    let themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
     (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
-      <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
+        <$  aformSection MsgFormCosmetics
+        <*> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
             (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
-      <*> areq (selectField . return $ mkOptionList themeList)
+        <*> areq (selectField . return $ mkOptionList themeList)
             (fslI  MsgTheme) { fsId = Just "theme-select" } (stgTheme         <$> template)
-      <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
+        <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
-      <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template)
+        <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template)
-      <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template)
+        <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template)
-      <*> areq checkBoxField (fslI MsgDownloadFiles
+        <*  aformSection MsgFormBehaviour
-                               & setTooltip MsgDownloadFilesTip
+        <*> areq checkBoxField (fslI MsgDownloadFiles
-                             ) (stgDownloadFiles <$> template)
+                                   & setTooltip MsgDownloadFilesTip
-      <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
+                                ) (stgDownloadFiles <$> template)
-      <*  submitButton
+        <*  aformSection MsgFormNotifications
+        <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
+        <*  submitButton
     return (result, widget) -- no validation required here
   where
+    themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
     nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
-
+--
+-- Version with proper grouping:
+--
+-- makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
+-- makeSettingForm template = identForm FIDsettings $ \html -> do
+--     (result, widget) <- flip (renderAForm FormStandard) html $ settingsFormT5T2
+--       <$> aFormGroup "Cosmetics"     cosmeticsForm
+--       <*> aFormGroup "Notifications" notificationsForm
+--       <*  submitButton
+--     return (result, widget) -- no validation required here
+--   where
+--     settingsFormT5T2 :: (Int,Theme,DateTimeFormat,DateTimeFormat,DateTimeFormat) -> (Bool,NotificationSettings) -> SettingsForm
+--     settingsFormT5T2 = $(uncurryN 2) . $(uncurryN 5) SettingsForm
+--     themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
+--     cosmeticsForm = (,,,,)
+--       <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
+--             (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
+--       <*> areq (selectField . return $ mkOptionList themeList)
+--             (fslI  MsgTheme) { fsId = Just "theme-select" } (stgTheme         <$> template)
+--       <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
+--       <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template)
+--       <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template)
+--     notificationsForm = (,)
+--       <$> areq checkBoxField (fslI MsgDownloadFiles
+--                                & setTooltip MsgDownloadFilesTip
+--                              ) (stgDownloadFiles <$> template)
+--       <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
+--     nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
 
 getProfileR, postProfileR :: Handler Html
 getProfileR = postProfileR

src/Handler/Term.hs

@@ -148,7 +148,7 @@ getTermEditR = do
   mbLastTerm <- runDB $ selectFirst [] [Desc TermName]
   let template = case mbLastTerm of
         Nothing -> mempty
-        (Just Entity{ entityVal=Term{..} }) -> let
+        (Just Entity{ entityVal=Term{..}}) -> let
             ntid = succ termName
             seas = season ntid
             yr   = year   ntid

src/Handler/Utils/Form.hs

@@ -156,10 +156,11 @@ natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Fi
 natIntField = natField
 
 posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
-posIntField d = checkBool (>= 1) (T.append  d " muss eine positive Zahl sein.") intField
+posIntField d = checkBool (> 0) (T.append  d " muss eine positive Zahl sein.") intField
 
+-- | Field to request integral number > 'm'
 minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
-minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) intField
+minIntField m d = checkBool (> m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) intField
 
 pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points --TODO allow fractions
 pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
@@ -289,7 +290,6 @@ multiFileField permittedFiles' = Field{..}
       Right _ -> return ()
       Left  r -> yield r
 
-
 data SheetGrading' = Points' | PassPoints' | PassBinary'
   deriving (Eq, Ord, Read, Show, Enum, Bounded)
 

src/Handler/Utils/Templates.hs

@@ -18,7 +18,7 @@ modal modalTrigger modalContent = do
         <a .modal__trigger href=#{route'} ##{triggerId}>
           <span .modal__trigger-label>^{modalTrigger}
       |]
-    Right _     -> -- do
+    Right _     ->
       [whamlet|
         $newline never
         <div .modal__trigger ##{triggerId}>

src/Utils/Form.hs

@@ -5,6 +5,7 @@ module Utils.Form where
 import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..))
 import Settings
 
+-- import Text.Blaze (toMarkup) -- for debugging
 import qualified Text.Blaze.Internal as Blaze (null)
 import qualified Data.Text as T
 
@@ -44,6 +45,38 @@ renderAForm formLayout aform fragment = do
   let widget = $(widgetFile "widgets/form/form")
   return (res, widget)
 
+-- | special id to identify form section headers, see 'aformSection' and 'formSection'
+--   currently only treated by form generation through 'renderAForm'
+idFormSectionNoinput :: Text
+idFormSectionNoinput = "form-section-noinput"
+
+-- | Generates a form having just a form-section-header and no input title.
+--   Currently only correctly rendered by 'renderAForm' and mforms using 'widget/form.hamlet'
+--   Usage:
+--   @
+--      (,) <$  formSection MsgInt
+--          <*> areq intField "int here" Nothing
+--          <*  formSection MsgDouble
+--          <*> areq doubleField "double there " Nothing
+--          <*  submitButton
+--   @
+--   If tooltips or other attributes are required, see 'formSection\'' instead.
+aformSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> AForm m ()
+aformSection = formToAForm . fmap (second pure) . formSection
+
+formSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete
+formSection formSectionTitle = do
+    mr <- getMessageRender
+    return (FormSuccess (), FieldView
+      { fvLabel    = toHtml $ mr formSectionTitle
+      , fvTooltip  = Nothing
+      , fvId       = idFormSectionNoinput
+      , fvErrors   = Nothing
+      , fvRequired = False
+      , fvInput    = mempty
+      })
+
+
 --------------------
 -- Field Settings --
 --------------------
@@ -323,6 +356,13 @@ submitButtonView = do
 -- Custom Fields --
 -------------------
 
+-- | empty field that has no view and always succeeds, useful for form sections having only a label
+noinputField :: Monad m => Field m ()
+noinputField = Field  { fieldEnctype = UrlEncoded
+                      , fieldParse = const $ const $ return $ Right $ Just ()
+                      , fieldView  = \_theId _name _attrs _val _isReq -> mempty
+                      }
+
 ciField :: ( Textual t
            , CI.FoldCase t
            , Monad m
@@ -386,6 +426,24 @@ optionsFinite = do
       }
   return . mkOptionList $ mkOption <$> universeF
 
+-------------------
+-- Special Forms --
+-------------------
+
+-- | Alternative implementation for 'aformSection' in a more standard that
+--  allows tooltips and arbitrary attributs. Section header must be given through `fsLabel`
+aformSection' :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site FormMessage) => FieldSettings site -> AForm m ()
+aformSection' = formToAForm . fmap (second pure) . formSection'
+
+-- | Alternative implementation for 'formSection' in a more standard that
+--  allows tooltips and arbitrary attributs. Section header must be given through `fsLabel`
+formSection' :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site FormMessage) =>
+   FieldSettings site  -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete
+formSection' formSectionTitleSettings = mreq noinputField sectionSettings Nothing
+  where
+    sectionSettings = formSectionTitleSettings { fsId = Just idFormSectionNoinput }
+
+
 
 ---------------------
 -- Form evaluation --
@@ -453,3 +511,5 @@ prismAForm :: Monad m => Prism' s a -> Maybe s ->  (Maybe a -> AForm m a) -> AFo
 prismAForm p outer form = review p <$> form inner
   where
     inner = outer >>= preview p
+
+

src/Utils/TH.hs

@@ -49,6 +49,23 @@ altFun perm = lamE pat rhs
         ps  = [ xs !! (j-1) | j <- perm ]
         fn  = mkName "fn"
 
+-- |
+curryN :: Int -> ExpQ
+curryN n = do
+  fn <- newName "foo"
+  xs <- replicateM n $ newName "x"
+  let pat = map VarP (fn:xs)
+  let tup = TupE (map VarE xs)
+  let rhs = AppE (VarE fn) tup
+  return $ LamE pat rhs
+
+uncurryN :: Int -> ExpQ
+uncurryN n = do
+  fn <- newName "foo"
+  xs <- replicateM n $ newName "x"
+  let pat = [VarP fn, TupP (map VarP xs)]
+  let rhs = foldl AppE (VarE fn) (map VarE xs)
+  return $ LamE pat rhs
 
 
 -- Special Show-Instances for Themes

static/css/utils/form.scss

@@ -11,6 +11,12 @@ fieldset {
   margin-bottom: 0;
 }
 
+@media (min-width: 769px) {
+  .form-group__input {
+    grid-column: 2;
+  }
+}
+
 [data-autosubmit][type="submit"] {
   animation: fade-in 500ms ease-in-out backwards;
   animation-delay: 500ms;

static/css/utils/inputs.scss

@@ -13,8 +13,16 @@
   border-left: 2px solid transparent;
 
   + .form-group {
-    margin-top: 13px;
+    margin-top: 7px;
   }
+
+  + .form-section-title {
+    margin-top: 40px;
+  }
+}
+
+.form-section-title {
+  color: var(--color-fontsec);
 }
 
 .form-group__label {
@@ -22,6 +30,12 @@
   padding-top: 6px;
 }
 
+.form-group__hint {
+  margin-top: 7px;
+  color: var(--color-fontsec);
+  font-size: 0.9rem;
+}
+
 .form-group--required {
 
   .form-group__label::after {

templates/featureList.hamlet

@@ -14,7 +14,7 @@
       <h4>
         neue geplante Features:
       <ul>
-        <li> Stundenplan/Kalender
+        <li> Stundenplan/Kalender mit Veranstaltungen und Klausuren
         <li> Vollständige Vorlesungshomepages
         <li> Vollständige Internationalisierung deutsch/englisch/...
 

templates/formPage.hamlet

@@ -1,2 +1,5 @@
+$newline never
+$#TODO: anchor must be generic for working with multiple forms
+<a id="forms">
 <form method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
   ^{formWidget}

templates/formPageI18n.hamlet

@@ -1,5 +1,8 @@
+$newline never
 $maybe text <- formText
-  <h3>
+  <h2>
     _{text}
+$#TODO: anchor must be generic for working with multiple forms
+<a id="forms">
 <form method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
-   ^{formWidget}
+  ^{formWidget}

templates/versionHistory.hamlet

@@ -1,6 +1,4 @@
 <div .container>
-  <h3>
-    Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>
 
   <section>
     ^{features}
@@ -8,13 +6,13 @@
   <section>
     <h2>
       Bekannte Bugs
+    <h3>
+      Stand: Februar 2019
     <ul>
       <li>
-        Login ist u.U. anders als im alten System, z.B. <span style="font-family:monospace">@campus.lmu.de</span> statt <span style="font-family:monospace">@lmu.de</span>
+        Login ist u.U. anders als im alten System, z.B. momentan geht nur <span style="font-family:monospace">@campus.lmu.de</span> aber nicht die Abkürzung <span style="font-family:monospace">@lmu.de</span>
       <li>
-        Favicon ist default des Frameworks
+        Format von Bewertungsdateien ist noch provisorisch
-      <li>
-        Format von Bewertungsdateien ist provisorisch
 
   <section>
     <h2>

templates/widgets/form/form.hamlet

@@ -7,14 +7,17 @@ $case formLayout
       ^{fvInput view}
   $of _
     $forall view <- fieldViews
-      $# TODO: add class 'form-group--submit' if this is the submit-button view
+      $if fvId view == idFormSectionNoinput
-      <div .form-group :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
+        <h3 .form-section-title>
-        $if not (Blaze.null $ fvLabel view)
+          ^{fvLabel view}
-          <label .form-group__label for=#{fvId view}>
+      $else
-            #{fvLabel view}
+        <div .form-group :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
-            $maybe tooltip <- fvTooltip view
+          $if not (Blaze.null $ fvLabel view)
-              <div .tooltip>
+            <label .form-group__label for=#{fvId view}>
-                <div .tooltip__handle>
+              #{fvLabel view}
-                <div .tooltip__content>^{tooltip}
+              $maybe hint <- fvTooltip view
-        <div .form-group__input>
+                <div .form-group__hint>^{hint}
-          ^{fvInput view}
+          <div .form-group__input>
+            ^{fvInput view}
+            $maybe err <- fvErrors view
+              <div .form-error>#{err}

test/Database.hs

@@ -218,9 +218,22 @@ fillDb = do
   repsert sdInf  $ StudyTerms  79 (Just "IfI") (Just "Institut für Informatik")
   repsert sdMath $ StudyTerms 105 (Just "MI" ) (Just "Mathematisches Institut")
   -- FFP
+  let nbrs :: [Int]
+      nbrs = [1,2,3,27,7,1]
   ffp <- insert' Course
     { courseName = "Fortgeschrittene Funktionale Programmierung"
-    , courseDescription = Just "<h2>It is fun!</h2>Come to where the functional is!"
+    , courseDescription = Just [shamlet|
+        <h2>It is fun!
+          <p>Come to where the functional is!
+          <section>
+            <h3>Functional programming can be done in Haskell!
+            <p>This is not a joke, this is serious!
+          <section>
+            <h3>Consider some numbers
+            <ul>
+              $forall n <- nbrs
+                <li>Number #{n}
+        |]
     , courseLinkExternal = Nothing
     , courseShorthand = "FFP"
     , courseTerm = TermKey summer2018