Merge branch 'alert-icons' into 'master'

feat(alert-icons): add custom icons for alerts

See merge request !258

frontend/src/utils/alerts/alerts.js

@@ -16,6 +16,11 @@ const ALERT_INVISIBLE_CLASS = 'alert--invisible';
 const ALERT_AUTO_HIDE_DELAY = 10;
 const ALERT_AUTOCLOSING_MATCHER = '.alert-info, .alert-success';
 
+/*
+ * Dataset-Inputs:
+ *  - decay (data-decay): Custom time (in seconds) for this alert to stay visible
+ */
+
 @Utility({
   selector: '[uw-alerts]',
 })
@@ -132,7 +137,7 @@ export class Alerts {
 
     if (alerts) {
       alerts.forEach((alert) => {
-        const alertElement = this._createAlertElement(alert.status, alert.content);
+        const alertElement = this._createAlertElement(alert.status, alert.content, alert.icon === null ? undefined : alert.icon);
         this._element.appendChild(alertElement);
         this._alertElements.push(alertElement);
         this._initAlert(alertElement);
@@ -142,7 +147,7 @@ export class Alerts {
     }
   }
 
-  _createAlertElement(type, content) {
+  _createAlertElement(type, content, icon = 'info-circle') {
     const alertElement = document.createElement('div');
     alertElement.classList.add(ALERT_CLASS, 'alert-' + type);
 
@@ -150,7 +155,7 @@ export class Alerts {
     alertCloser.classList.add(ALERT_CLOSER_CLASS);
 
     const alertIcon = document.createElement('div');
-    alertIcon.classList.add(ALERT_ICON_CLASS);
+    alertIcon.classList.add(ALERT_ICON_CLASS, 'fas', 'fa-fw', 'fa-' + icon);
 
     const alertContent = document.createElement('div');
     alertContent.classList.add(ALERT_CONTENT_CLASS);

frontend/src/utils/alerts/alerts.scss

@@ -32,6 +32,10 @@
     font-size: 30px;
     transform: translateX(-50%);
   }
+
+  &:hover::before {
+    color: var(--color-grey-medium);
+  }
 }
 
 .alerts--elevated {
@@ -68,6 +72,10 @@
 
 .alert a {
   color: var(--color-lightwhite);
+
+  &:hover {
+    color: var(--color-grey);
+  }
 }
 
 @keyframes slide-in-alert {
@@ -124,9 +132,9 @@
   z-index: 40;
 
   &::before {
-    content: '\f05a';
+    /* content: var(--alert-icon, var(--alert-icon-default, '\f05a')); */
     position: absolute;
-    font-family: 'Font Awesome 5 Free';
+    /* font-family: 'Font Awesome 5 Free'; */
     font-size: 24px;
     top: 50%;
     left: 50%;
@@ -188,23 +196,26 @@
 .alert-success {
   background-color: var(--color-success);
 
-  .alert__icon::before {
+  /* .alert__icon::before {
-    content: '\f058';
+   *   --alert-icon-default: '\f058';
-  }
+   * }
+   */
 }
 
 .alert-warning {
   background-color: var(--color-warning);
 
-  .alert__icon::before {
+  /* .alert__icon::before {
-    content: '\f06a';
+   *   --alert-icon-default: '\f06a';
-  }
+   * }
+   */
 }
 
 .alert-error {
   background-color: var(--color-error);
 
-  .alert__icon::before {
+  /* .alert__icon::before {
-    content: '\f071';
+   *   --alert-icon-default: '\f071';
-  }
+   * }
+   */
 }

src/Database/Esqueleto/Utils.hs

@@ -29,6 +29,10 @@ import Database.Esqueleto.Utils.TH
 {-# ANN all ("HLint: ignore Use all" :: String) #-}
 
 
+{-# ANN any ("HLint: ignore Use any" :: String) #-}
+{-# ANN all ("HLint: ignore Use all" :: String) #-}
+
+
 --
 -- Description : Convenience for using `Esqueleto`,
 --               intended to be imported qualified

src/Foundation.hs

@@ -5,7 +5,7 @@
 module Foundation where
 
 import Import.NoFoundation hiding (embedFile)
-import qualified ClassyPrelude.Yesod as Yesod (addMessage, getHttpManager)
+import qualified ClassyPrelude.Yesod as Yesod (getHttpManager)
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Text.Hamlet          (hamletFile)
 
@@ -1215,9 +1215,8 @@ instance Yesod UniWorX where
             , massInputShortcircuit
             ]
 
-          lift . bracketOnError getMessages (mapM_ $ uncurry Yesod.addMessage) $ \msgs -> do
+          lift . bracketOnError getMessages (mapM_ addMessage') $
-            Just msgs' <- return . forM msgs $ \(msgState, content) -> Message <$> fromPathPiece msgState <*> return content
+            addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode
-            addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict $ JSON.encode msgs'
 
     -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget`
     defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"
@@ -2849,6 +2848,12 @@ instance YesodAuth UniWorX where
 
     authHttpManager = Yesod.getHttpManager
 
+    onLogin = addMessageI Success Auth.NowLoggedIn
+
+    onErrorHtml dest msg = do
+      addMessage Error $ toHtml msg
+      redirect dest
+
     renderAuthMessage _ _ = Auth.germanMessage -- TODO
 
 instance YesodAuthPersist UniWorX

src/Handler/Admin.hs

@@ -113,7 +113,7 @@ postAdminTestR = do
   formResultModal emailResult AdminTestR $ \(email, ls) -> do
     jId <- mapWriterT runDB $ do
       jId <- queueJob $ JobSendTestEmail email ls
-      tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|]
+      tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail)
       return jId
     writeJobCtl $ JobCtlPerform jId
     addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal`

src/Handler/Course.hs

@@ -557,11 +557,11 @@ postCRegisterR tid ssh csh = do
   formResult regResult $ \(mbSfId,codeOk) -> if
       | isRegistered -> do
           runDB $ deleteBy $ UniqueParticipant aid cid
-          addMessageI Info MsgCourseDeregisterOk
+          addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
       | codeOk -> do
           actTime <- liftIO getCurrentTime
           regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId
-          when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
+          when (isJust regOk) $ addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
       | otherwise -> addMessageI Warning MsgCourseSecretWrong
   -- addMessage Info $ toHtml $ show regResult -- For debugging only
   redirect $ CourseR tid ssh csh CShowR
@@ -1419,7 +1419,7 @@ postCUserR tid ssh csh uCId = do
       | Just (Entity pId _) <- mRegistration
         -> do
           runDB $ delete pId
-          addMessageI Info MsgCourseDeregisterOk
+          addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
           redirect $ CourseR tid ssh csh CUsersR
       | otherwise
         -> invalidArgs ["User not registered"]
@@ -1433,7 +1433,7 @@ postCUserR tid ssh csh uCId = do
       pId <- runDB . insertUnique $ CourseParticipant cid uid now primaryField
       case pId of
         Just _  -> do
-          addMessageI Success MsgCourseRegisterOk
+          addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
           redirect currentRoute
         Nothing -> invalidArgs ["User already registered"]
 

src/Handler/Exam.hs

@@ -1518,21 +1518,14 @@ postERegisterR tid ssh csh examn = do
         now <- liftIO getCurrentTime
         insert_ $ ExamRegistration eId uid Nothing now
         audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
-      addMessageWidget Success [whamlet|
+      addMessageIconI Success IconExamRegisterTrue  (MsgExamRegisteredSuccess examn)
-          <div>#{iconExamRegister True}
-          <div>&nbsp;
-          <div>_{MsgExamRegisteredSuccess   examn}
-          |]
       redirect $ CExamR tid ssh csh examn EShowR
     BtnExamDeregister -> do
       runDB $ do
         deleteBy $ UniqueExamRegistration eId uid
         audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
-      addMessageWidget Info [whamlet|
+      addMessageIconI Info    IconExamRegisterFalse (MsgExamDeregisteredSuccess examn)
-        <div>#{iconExamRegister False}
+      -- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4
-        <div>&nbsp;
-        <div>_{MsgExamDeregisteredSuccess examn}
-        |] -- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4
       redirect $ CExamR tid ssh csh examn EShowR
 
   invalidArgs ["Register/Deregister button required"]

src/Handler/Utils/Table/Cells.hs

@@ -122,8 +122,7 @@ isNewCell = cell . toWidget . isNew
 -- | Maybe display comment icon linking a given URL or show nothing at all
 commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a
 commentCell Nothing     = mempty
-commentCell (Just link) = anchorCell link icon
+commentCell (Just link) = anchorCell link $ hasComment True
-  where icon = hasComment True
 
 -- | whether something is visible or hidden
 isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a
@@ -134,11 +133,15 @@ isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass
 
 -- | for simple file downloads
 fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a
-fileCell route = anchorCell route fileDownload
+fileCell route = anchorCell route iconFileDownload
 
 -- | for zip-archive downloads
 zipCell :: IsDBTable m a => Route UniWorX -> DBCell m a
-zipCell route = anchorCell route zipDownload
+zipCell route = anchorCell route iconFileZip
+
+-- | for csv downloads
+csvCell :: IsDBTable m a => Route UniWorX -> DBCell m a
+csvCell route = anchorCell route iconFileCSV
 
 -- | Display an icon that opens a modal upon clicking
 modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a
@@ -197,11 +200,11 @@ cellHasEMail = emailCell . view _userEmail
 cellHasSemester :: (IsDBTable m c, HasStudyFeatures a) => a -> DBCell m c
 cellHasSemester = numCell . view _studyFeaturesSemester
 
-  
+
 cellHasField :: (IsDBTable m c, HasStudyTerms a) => a -> DBCell m c
 cellHasField x = maybe (numCell $ x ^. _studyTermsKey) textCell $ x ^. _studyTermsName <|> x ^. _studyTermsShorthand
 
-  
+
 cellHasDegreeShort :: (IsDBTable m c, HasStudyDegree a) => a -> DBCell m c
 cellHasDegreeShort x = maybe (numCell $ x ^. _studyDegreeKey) textCell $ x ^. _studyDegreeShorthand <|> x ^. _studyDegreeName
 

src/Handler/Utils/Table/Pagination.hs

@@ -305,7 +305,7 @@ instance Button UniWorX ButtonCsvMode where
   btnLabel BtnCsvExport
     = [whamlet|
         $newline never
-        #{iconCSV}
+        #{iconFileCSV}
         \ _{BtnCsvExport}
       |]
   btnLabel x = [whamlet|_{x}|]

src/Import/NoModel.hs

@@ -3,7 +3,7 @@ module Import.NoModel
   , MForm
   ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons, HasHttpManager(..))
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, getMessages, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons, HasHttpManager(..))
 
 import Model.Types.TH.JSON as Import
 import Model.Types.TH.Wordlist as Import
@@ -54,7 +54,7 @@ import Data.Ratio             as Import ((%))
 import Net.IP                 as Import (IP)
 
 import Database.Persist.Sql as Import (SqlReadT, SqlWriteT, fromSqlKey, toSqlKey)
-  
+
 import Ldap.Client.Pool as Import
 
 import System.Random as Import (Random(..))
@@ -71,7 +71,7 @@ import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC)
 import Time.Types as Import (WeekDay(..))
 
 import Network.Mime as Import
-  
+
 import Data.Aeson.TH as Import
 import Data.Aeson.Types as Import (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..), ToJSONKeyFunction(..), Value)
 

src/Language/Haskell/TH/Instances.hs

@@ -7,8 +7,18 @@ module Language.Haskell.TH.Instances
 import Language.Haskell.TH
 import Language.Haskell.TH.Lift (deriveLift)
 import Data.Binary (Binary)
-
+import Data.Semigroup
+import Data.Monoid ()
+import Control.Applicative
 
 instance Binary Loc
 
 deriveLift ''Loc
+
+
+instance Semigroup (Q [Dec]) where
+  (<>) = liftA2 (<>)
+
+instance Monoid (Q [Dec]) where
+  mempty  = pure mempty
+  mappend = (<>)

src/Model/Types/Sheet.hs

@@ -171,10 +171,10 @@ instance PathPiece SheetFileType where
   fromPathPiece = finiteFromPathPiece
 
 sheetFile2markup :: SheetFileType -> Markup
-sheetFile2markup SheetExercise = iconQuestion
+sheetFile2markup SheetExercise = iconSFTQuestion
-sheetFile2markup SheetHint     = iconHint
+sheetFile2markup SheetHint     = iconSFTHint
-sheetFile2markup SheetSolution = iconSolution
+sheetFile2markup SheetSolution = iconSFTSolution
-sheetFile2markup SheetMarking  = iconMarking
+sheetFile2markup SheetMarking  = iconSFTMarking
 
 -- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a)
 -- partitionFileType' = groupMap

src/Utils.hs

@@ -23,6 +23,7 @@ import Utils.TH as Utils
 import Utils.DateTime as Utils
 import Utils.PathPiece as Utils
 import Utils.Route as Utils
+import Utils.Icon as Utils
 import Utils.Message as Utils
 import Utils.Lang as Utils
 import Utils.Parameters as Utils
@@ -80,9 +81,10 @@ import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, Bounded
 
 import Data.Constraint (Dict(..))
 
-{-# ANN choice ("HLint: ignore Use asum" :: String) #-}
+{-# ANN module ("HLint: ignore Use asum" :: String) #-}
 
 
+$(iconShortcuts) -- declares constants for all known icons
 
 -----------
 -- Yesod --
@@ -113,122 +115,10 @@ unsupportedAuthPredicate = do
         unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route)
     |]
 
-
+-- | allows conditional attributes in hamlet via *{..} syntax
-
+maybeAttribute :: Text -> (a -> Text) -> Maybe a -> [(Text,Text)]
--- | A @Widget@ for any site; no language interpolation, etc.
+maybeAttribute _ _ Nothing  = []
-type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m)
+maybeAttribute a c (Just v) = [(a,c v)]
-  => WidgetT site m ()
-
-
------------
--- Icons --
------------
-
--- Create an icon from font-awesome without additional space
-fontAwesomeIcon :: Text -> Markup
-fontAwesomeIcon iconName =
-  [shamlet|$newline never
-            <i .fas .fa-#{iconName}>|]
-
--- We collect all used icons here for an overview.
--- For consistency, some conditional icons are also provided, e.g. `isIvisble`
-
-iconQuestion :: Markup
-iconQuestion = fontAwesomeIcon "question-circle"
-
-iconNew :: Markup
-iconNew = fontAwesomeIcon "seedling"
-
-iconOK :: Markup
-iconOK = fontAwesomeIcon "check"
-
-iconNotOK :: Markup
-iconNotOK = fontAwesomeIcon "times"
-
-iconWarning :: Markup
-iconWarning = fontAwesomeIcon "exclamation"
-
-iconProblem :: Markup
-iconProblem = fontAwesomeIcon "bolt"
-
-iconHint :: Markup
-iconHint = fontAwesomeIcon "life-ring"
-
--- Icons for Course
-iconCourse :: Markup
-iconCourse = fontAwesomeIcon "graduation-cap"
-
-iconExam :: Markup
-iconExam = fontAwesomeIcon "file-invoice"
-
-iconEnrol :: Bool -> Markup
-iconEnrol True  = fontAwesomeIcon "user-plus"
-iconEnrol False = fontAwesomeIcon "user-slash"
-
-iconExamRegister :: Bool -> Markup
-iconExamRegister True  = fontAwesomeIcon "calendar-check"
-iconExamRegister False = fontAwesomeIcon "calendar-times"
-
-
--- Icons for SheetFileType
-iconSolution :: Markup
-iconSolution =fontAwesomeIcon "exclamation-circle"
-
-iconMarking :: Markup
-iconMarking = fontAwesomeIcon "check-circle"
-
-fileDownload :: Markup
-fileDownload = fontAwesomeIcon "file-download"
-
-zipDownload :: Markup
-zipDownload = fontAwesomeIcon "file-archive"
-
-iconCSV :: Markup
-iconCSV = fontAwesomeIcon "file-csv"
-
-
--- Generic Conditional icons
-
-isVisible :: Bool -> Markup
--- ^ Display an icon that denotes that something™ is visible or invisible
-isVisible True  = fontAwesomeIcon "eye"
-isVisible False = fontAwesomeIcon "eye-slash"
---
--- For documentation on how to avoid these unneccessary functions
--- we implement them here just once for the first icon:
---
-isVisibleWidget :: Bool -> WidgetSiteless
--- ^ Widget having an icon that denotes that something™ is visible or invisible
-isVisibleWidget = toWidget . isVisible
-
-maybeIsVisibleWidget :: Maybe Bool -> WidgetSiteless
--- ^ Maybe a widget with an icon that denotes that something™ is visible or invisible
-maybeIsVisibleWidget = toWidget . foldMap isVisible
-
--- Other _frequently_ used icons:
-hasComment :: Bool -> Markup
--- ^ Display an icon that denotes that something™ has a comment or not
-hasComment True  = fontAwesomeIcon "comment-alt"
-hasComment False = fontAwesomeIcon "comment-slash" -- comment-alt-slash is not available for free
-
-hasTickmark :: Bool -> Markup
--- ^ Display an icon that denotes that something™ is okay
-hasTickmark True  = iconOK
-hasTickmark False = mempty
-
-isBad :: Bool -> Markup
--- ^ Display an icon that denotes that something™ is bad
-isBad True  = iconProblem
-isBad False = mempty
-
-isNew :: Bool -> Markup
-isNew True  = iconNew
-isNew False = mempty
-
-boolSymbol :: Bool -> Markup
-boolSymbol True  = iconOK
-boolSymbol False = iconNotOK
-
 
 
 ---------------------

src/Utils/Form.hs

@@ -751,15 +751,15 @@ wformMessage :: (MonadHandler m) => Message -> WForm m ()
 wformMessage = void . aFormToWForm . aformMessage
 
 formMessage :: (MonadHandler m) => Message -> MForm m (FormResult (), FieldView site)
-formMessage Message{..} = do
+formMessage Message{ messageIcon = _, ..} = do -- custom icons are not currently implemented for `.notification`
-    return (FormSuccess (), FieldView
+  return (FormSuccess (), FieldView
-      { fvLabel    = mempty
+    { fvLabel    = mempty
-      , fvTooltip  = Nothing
+    , fvTooltip  = Nothing
-      , fvId       = idFormMessageNoinput
+    , fvId       = idFormMessageNoinput
-      , fvErrors   = Nothing
+    , fvErrors   = Nothing
-      , fvRequired = False
+    , fvRequired = False
-      , fvInput    = [whamlet|<div .notification .notification-#{toPathPiece messageStatus}>#{messageContent}|]
+    , fvInput    = [whamlet|<div .notification .notification-#{toPathPiece messageStatus}>#{messageContent}|]
-      })
+    })
 
 ---------------------
 -- Form evaluation --

src/Utils/Icon.hs

@@ -0,0 +1,168 @@
+module Utils.Icon where
+
+import ClassyPrelude.Yesod hiding (Proxy)
+
+import Data.Universe
+import Data.Char
+import Utils.PathPiece
+-- import Text.Hamlet
+import Text.Blaze (Markup)
+import Control.Lens
+import Language.Haskell.TH
+import Language.Haskell.TH.Instances ()
+import Language.Haskell.TH.Lift (deriveLift)
+import Instances.TH.Lift ()
+import Data.Aeson
+import Data.Aeson.TH
+
+-- | A @Widget@ for any site; no language interpolation, etc.
+type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m)
+  => WidgetT site m ()
+
+
+-----------
+-- Icons --
+-----------
+-- We collect all used icons here for an overview.
+-- For consistency, some conditional icons are also provided, having suffix True/False
+
+---------------------------------------------------------------------------
+-- IMPORTANT: Alert-Icons must be registered in alert-icons.js as well!!!
+---------------------------------------------------------------------------
+data Icon
+  = IconNew
+  | IconOK
+  | IconNotOK
+  | IconWarning
+  | IconProblem
+  | IconVisible
+  | IconInvisible
+  | IconCourse
+  | IconEnrolTrue
+  | IconEnrolFalse
+  | IconExam
+  | IconExamRegisterTrue
+  | IconExamRegisterFalse
+  | IconCommentTrue
+  | IconCommentFalse
+  | IconLink
+  | IconFileDownload
+  | IconFileZip
+  | IconFileCSV
+  | IconSFTQuestion  -- for SheetFileType only
+  | IconSFTHint      -- for SheetFileType only
+  | IconSFTSolution  -- for SheetFileType only
+  | IconSFTMarking   -- for SheetFileType only
+  | IconEmail
+  deriving (Eq, Ord, Enum, Bounded, Show, Read)
+
+iconText :: Icon -> Text
+iconText = \case
+    IconNew                -> "seedling"
+    IconOK                 -> "check"
+    IconNotOK              -> "times"
+    IconWarning            -> "exclamation"
+    IconProblem            -> "bolt"
+    IconVisible            -> "eye"
+    IconInvisible          -> "eye-slash"
+    IconCourse             -> "graduation-cap"
+    IconEnrolTrue          -> "user-plus"
+    IconEnrolFalse         -> "user-slash"
+    IconExam               -> "file-invoice"
+    IconExamRegisterTrue   -> "calendar-check"
+    IconExamRegisterFalse  -> "calendar-times"
+    IconCommentTrue        -> "comment-alt"
+    IconCommentFalse       -> "comment-slash"      -- comment-alt-slash is not available for free
+    IconLink               -> "link"
+    IconFileDownload       -> "file-download"
+    IconFileZip            -> "file-archive"
+    IconFileCSV            -> "file-csv"
+    IconSFTQuestion        -> "question-circle"    -- for SheetFileType only, should all be round (similar)
+    IconSFTHint            -> "life-ring"          -- for SheetFileType only
+    IconSFTSolution        -> "exclamation-circle" -- for SheetFileType only
+    IconSFTMarking         -> "check-circle"       -- for SheetFileType only
+    IconEmail              -> "envelope"
+
+instance Universe Icon
+instance Finite   Icon
+nullaryPathPiece ''Icon $ camelToPathPiece' 1
+deriveLift ''Icon
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  } ''Icon
+
+-- Create an icon from font-awesome without additional space
+icon :: Icon -> Markup
+icon ic = [shamlet|
+            $newline never
+            <i .fas .fa-#{iconText ic}>
+          |]
+
+-- declare constats for all icons for compatibility and convenience
+-- "IconCourse" generates "iconCourse = icon IconCourse"
+iconShortcuts :: Q [Dec]
+iconShortcuts = foldMap mkIcon (universeF :: [Icon])
+  where
+    mkIcon :: Icon -> Q [Dec]
+    mkIcon ic = do
+      iname <- newName $ over (ix 0) Data.Char.toLower $ show ic
+      isig <- sigD iname [t|Markup|]
+      idef <- valD (varP iname) (normalB [|icon ic|]) []
+      return [isig, idef]
+
+
+----------------------
+-- Conditional icons
+--
+-- Some case are special, hence no Template Haskell here
+
+isVisible :: Bool -> Markup
+-- ^ Display an icon that denotes that something™ is visible or invisible
+isVisible True  = icon IconVisible
+isVisible False = icon IconInvisible
+
+hasComment :: Bool -> Markup
+-- ^ Display an icon that denotes that something™ has a comment or not
+hasComment True  = icon IconCommentTrue
+hasComment False = icon IconCommentFalse
+
+hasTickmark :: Bool -> Markup
+-- ^ Maybe display an icon that denotes that something™ is okay
+hasTickmark True  = icon IconOK
+hasTickmark False = mempty
+
+isBad :: Bool -> Markup
+-- ^ Maybe display an icon that denotes that something™ is bad
+isBad True  = icon IconProblem
+isBad False = mempty
+
+-- ^ Maybe display an icon that denotes that something™ is bad
+isNew :: Bool -> Markup
+isNew True  = icon IconNew
+isNew False = mempty
+
+boolSymbol :: Bool -> Markup
+boolSymbol True  = icon IconOK
+boolSymbol False = icon IconNotOK
+
+iconEnrol :: Bool -> Markup
+iconEnrol True  = icon IconEnrolTrue
+iconEnrol False = icon IconEnrolFalse
+
+iconExamRegister :: Bool -> Markup
+iconExamRegister True  = icon IconExamRegisterTrue
+iconExamRegister False = icon IconExamRegisterFalse
+
+
+----------------
+-- For documentation on how to avoid these unneccessary functions
+-- we implement them here just once for the first icon:
+--
+isVisibleWidget :: Bool -> WidgetSiteless
+-- ^ Widget having an icon that denotes that something™ is visible or invisible
+isVisibleWidget = toWidget . isVisible
+
+maybeIsVisibleWidget :: Maybe Bool -> WidgetSiteless
+-- ^ Maybe a widget with an icon that denotes that something™ is visible or invisible
+maybeIsVisibleWidget = toWidget . foldMap isVisible

src/Utils/Message.hs

@@ -1,6 +1,8 @@
 module Utils.Message
   ( MessageStatus(..)
-  , UnknownMessageStatus(..)
+  -- , UnknownMessageStatus(..)
+  , getMessages
+  , addMessage',addMessageIcon, addMessageIconI -- messages with special icons (needs registering in alert-icons.js)
   , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget
   , statusToUrgencyClass
   , Message(..)
@@ -8,12 +10,13 @@ module Utils.Message
   ) where
 
 import Data.Universe
+import Utils.Icon
 import Utils.PathPiece
 import Data.Aeson
 import Data.Aeson.TH
 
-import qualified ClassyPrelude.Yesod (addMessage, addMessageI)
+import qualified ClassyPrelude.Yesod (addMessage, addMessageI, getMessages)
-import ClassyPrelude.Yesod hiding (addMessage, addMessageI)
+import ClassyPrelude.Yesod hiding (addMessage, addMessageI, getMessages)
 
 import Text.Hamlet
 
@@ -28,8 +31,11 @@ import Text.HTML.SanitizeXSS (sanitizeBalance)
 data MessageStatus = Error | Warning | Info | Success
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift)
 
+
 instance Universe MessageStatus
 instance Finite   MessageStatus
+instance Default  MessageStatus where
+  def = Info
 
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece
@@ -38,15 +44,55 @@ deriveJSON defaultOptions
 nullaryPathPiece ''MessageStatus camelToPathPiece
 derivePersistField "MessageStatus"
 
-newtype UnknownMessageStatus = UnknownMessageStatus Text
+newtype UnknownMessageStatus = UnknownMessageStatus Text -- kann das weg?
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 instance Exception UnknownMessageStatus
 
 
+data MessageIconStatus = MIS { misStatus :: MessageStatus, misIcon :: Maybe Icon }
+  deriving (Eq, Ord, Show, Read, Lift)
+
+instance Default MessageIconStatus where
+  def = MIS { misStatus=def, misIcon=Nothing }
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''MessageIconStatus
+
+encodeMessageStatus :: MessageStatus -> Text
+encodeMessageStatus ms = encodeMessageIconStatus $ def{ misStatus=ms }
+
+encodeMessageIconStatus :: MessageIconStatus -> Text
+encodeMessageIconStatus = decodeUtf8 . toStrict . encode
+
+decodeMessageIconStatus :: Text -> Maybe MessageIconStatus
+decodeMessageIconStatus = decode' . fromStrict . encodeUtf8
+
+-- decodeMessageIconStatus' :: Text -> MessageIconStatus
+-- decodeMessageIconStatus' t
+--   | Just mis <- decodeMessageIconStatus t = mis
+--   | otherwise = def
+
+decodeMessage :: (Text, Html) -> Message
+decodeMessage (mis, msgContent)
+  | Just MIS{ misStatus=messageStatus, misIcon=messageIcon } <- decodeMessageIconStatus mis
+    = let messageContent = msgContent in Message{..}
+  | Just messageStatus <- fromPathPiece mis -- should not happen
+    = let messageIcon    = Nothing
+          messageContent = msgContent <> "!!" -- mark legacy case, should no longer occur ($logDebug instead ???)
+      in  Message{..}
+  | otherwise -- should not happen
+    = let messageStatus  = Utils.Message.Error
+          messageContent = msgContent <> "!!!" -- mark legacy case, should no longer occur ($logDebug instead ???)
+          messageIcon    = Nothing
+      in  Message{..}
+
+
 data Message = Message
-  { messageStatus :: MessageStatus
+  { messageStatus  :: MessageStatus
   , messageContent :: Html
+  , messageIcon    :: Maybe Icon
   }
 
 instance Eq Message where
@@ -59,26 +105,39 @@ instance ToJSON Message where
   toJSON Message{..} = object
     [ "status" .= messageStatus
     , "content" .= renderHtml messageContent
+    , "icon" .= messageIcon
     ]
 
 instance FromJSON Message where
   parseJSON = withObject "Message" $ \o -> do
     messageStatus <- o .: "status"
     messageContent <- preEscapedText . sanitizeBalance <$> o .: "content"
+    messageIcon <- o .: "icon"
     return Message{..}
 
 statusToUrgencyClass :: MessageStatus -> Text
 statusToUrgencyClass status = "urgency__" <> toPathPiece status
 
+addMessage' :: MonadHandler m => Message -> m ()
+addMessage' Message{..} = ClassyPrelude.Yesod.addMessage (encodeMessageIconStatus mis) messageContent
+    where mis = MIS{misStatus=messageStatus, misIcon=messageIcon}
+
+addMessageIcon :: MonadHandler m => MessageStatus -> Icon -> Html -> m ()
+addMessageIcon ms mi = ClassyPrelude.Yesod.addMessage $ encodeMessageIconStatus MIS{misStatus=ms, misIcon=Just mi}
+
+addMessageIconI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> Icon -> msg -> m ()
+addMessageIconI ms mi = ClassyPrelude.Yesod.addMessageI $ encodeMessageIconStatus MIS{misStatus=ms, misIcon=Just mi}
+
 addMessage :: MonadHandler m => MessageStatus -> Html -> m ()
-addMessage mc  = ClassyPrelude.Yesod.addMessage  (toPathPiece mc)
+addMessage mc  = ClassyPrelude.Yesod.addMessage $ encodeMessageStatus mc
 
 addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m ()
-addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc)
+addMessageI mc = ClassyPrelude.Yesod.addMessageI $ encodeMessageStatus mc
 
 messageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m Message
 messageI messageStatus msg = do
   messageContent <- toHtml . ($ msg) <$> getMessageRender
+  let messageIcon = Nothing
   return Message{..}
 
 addMessageIHamlet :: ( MonadHandler m
@@ -87,15 +146,16 @@ addMessageIHamlet :: ( MonadHandler m
                      ) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m ()
 addMessageIHamlet mc iHamlet = do
   mr <- getMessageRender
-  ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr)
+  ClassyPrelude.Yesod.addMessage (encodeMessageStatus mc) =<< withUrlRenderer (iHamlet $ toHtml . mr)
 
 messageIHamlet :: ( MonadHandler m
                   , RenderMessage (HandlerSite m) msg
                   , HandlerSite m ~ site
                   ) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m Message
-messageIHamlet mc iHamlet = do
+messageIHamlet ms iHamlet = do
   mr <- getMessageRender
-  Message mc <$> withUrlRenderer (iHamlet $ toHtml . mr)
+  let mi = Nothing
+  Message ms <$> withUrlRenderer (iHamlet $ toHtml . mr) <*> pure mi
 
 addMessageFile :: MessageStatus -> FilePath -> ExpQ
 addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|]
@@ -122,3 +182,9 @@ messageWidget :: forall m site.
 messageWidget mc wgt = do
   PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt
   messageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site))
+
+
+getMessages :: MonadHandler m => m [Message]
+getMessages = fmap decodeMessage <$> ClassyPrelude.Yesod.getMessages
+
+

templates/corrections-overview.hamlet

@@ -56,8 +56,10 @@
 
       $#  Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table
       $forall shn <- orderedSheetNames
-        <th .table__th colspan=5>#{shn}
+        <th .table__th colspan=5>
-        $# ^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)}
+          $# Links currently look ugly in table headers; used an icon as a workaround:
+          ^{simpleLink (toWidget iconLink) (CSheetR tid ssh csh shn SShowR)}
+          #{shn}
     <tr .table__row .table__row--head>
       <th .table__th>_{MsgNrSubmissionsTotal}
       <th .table__th>_{MsgNrSubmissionsNotCorrected}

templates/exam-show.hamlet

@@ -24,7 +24,7 @@ $maybe Entity _ ExamResult{examResultResult} <- result
 $maybe desc <- examDescription
   <section>
     #{desc}
-  
+
 <section>
   <dl .deflist>
     $if not examVisible
@@ -84,7 +84,7 @@ $maybe desc <- examDescription
     $maybe registerWdgt <- registerWidget
       <dt .deflist__dt>_{MsgExamRegistration}
       <dd .deflist__dd>^{registerWdgt}
-    
+
 
 $if not (null occurrences)
   <section>
@@ -124,7 +124,7 @@ $if not (null occurrences)
             $if occurrenceAssignmentsShown
               <td .table__td>
                 $if registered
-                  #{fontAwesomeIcon "check"}
+                  #{iconOK}
 
 $if gradingShown && not (null parts)
   <section>
@@ -151,7 +151,7 @@ $if gradingShown && not (null parts)
                 $of Just (ExamAttended (Just ps))
                   #{showFixed True ps}
                 $of Just (ExamAttended Nothing)
-                  #{fontAwesomeIcon "check"}
+                  #{iconOK}
                 $of Just ExamNoShow
                   _{MsgExamNoShow}
                 $of Just ExamVoided

templates/widgets/alerts/alerts.hamlet

@@ -1,10 +1,9 @@
 $newline never
 <div #alerts-1 .alerts uw-alerts>
   <div .alerts__toggler>
-  $forall (status, msg) <- mmsgs
+  $forall Message{..} <- mmsgs
-    $with status2 <- bool status "info" (status == "")
+    <div .alert .alert-#{toPathPiece messageStatus}>
-      <div .alert.alert-#{status2}>
+      <div .alert__closer>
-        <div .alert__closer>
+      <div .alert__icon .fas .fa-fw .fa-#{maybe "info-circle" iconText messageIcon}>
-        <div .alert__icon>
+      <div .alert__content>
-        <div .alert__content>
+        #{messageContent}
-          #{msg}