_{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
+ addMessageIconI Info IconExamRegisterFalse (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"]
diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs
index 948febc54..2620ee83f 100644
--- a/src/Handler/Utils/Table/Cells.hs
+++ b/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
- where icon = hasComment True
+commentCell (Just link) = anchorCell link $ 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
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index e36c0672b..27f476312 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/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}|]
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index 2385d2d99..e530b0d0f 100644
--- a/src/Import/NoModel.hs
+++ b/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)
diff --git a/src/Language/Haskell/TH/Instances.hs b/src/Language/Haskell/TH/Instances.hs
index 48c419705..d4730efe6 100644
--- a/src/Language/Haskell/TH/Instances.hs
+++ b/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 = (<>)
diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs
index 4a6c60a32..2f6e43200 100644
--- a/src/Model/Types/Sheet.hs
+++ b/src/Model/Types/Sheet.hs
@@ -171,10 +171,10 @@ instance PathPiece SheetFileType where
fromPathPiece = finiteFromPathPiece
sheetFile2markup :: SheetFileType -> Markup
-sheetFile2markup SheetExercise = iconQuestion
-sheetFile2markup SheetHint = iconHint
-sheetFile2markup SheetSolution = iconSolution
-sheetFile2markup SheetMarking = iconMarking
+sheetFile2markup SheetExercise = iconSFTQuestion
+sheetFile2markup SheetHint = iconSFTHint
+sheetFile2markup SheetSolution = iconSFTSolution
+sheetFile2markup SheetMarking = iconSFTMarking
-- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a)
-- partitionFileType' = groupMap
diff --git a/src/Utils.hs b/src/Utils.hs
index 1792d9af8..982ba28f5 100644
--- a/src/Utils.hs
+++ b/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)
|]
-
-
--- | 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 --
------------
-
--- Create an icon from font-awesome without additional space
-fontAwesomeIcon :: Text -> Markup
-fontAwesomeIcon iconName =
- [shamlet|$newline never
-
|]
-
--- 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
-
+-- | allows conditional attributes in hamlet via *{..} syntax
+maybeAttribute :: Text -> (a -> Text) -> Maybe a -> [(Text,Text)]
+maybeAttribute _ _ Nothing = []
+maybeAttribute a c (Just v) = [(a,c v)]
---------------------
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 73e6473e4..e1a2a24b4 100644
--- a/src/Utils/Form.hs
+++ b/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
- return (FormSuccess (), FieldView
- { fvLabel = mempty
- , fvTooltip = Nothing
- , fvId = idFormMessageNoinput
- , fvErrors = Nothing
- , fvRequired = False
- , fvInput = [whamlet|#{messageContent}|]
- })
+formMessage Message{ messageIcon = _, ..} = do -- custom icons are not currently implemented for `.notification`
+ return (FormSuccess (), FieldView
+ { fvLabel = mempty
+ , fvTooltip = Nothing
+ , fvId = idFormMessageNoinput
+ , fvErrors = Nothing
+ , fvRequired = False
+ , fvInput = [whamlet|
#{messageContent}|]
+ })
---------------------
-- Form evaluation --
diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs
new file mode 100644
index 000000000..582f9f35c
--- /dev/null
+++ b/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
+
+ |]
+
+-- 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
diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs
index 04dc41dcf..d72d065bf 100644
--- a/src/Utils/Message.hs
+++ b/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 ClassyPrelude.Yesod hiding (addMessage, addMessageI)
+import qualified ClassyPrelude.Yesod (addMessage, addMessageI, getMessages)
+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
+
+
diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet
index 64a647387..747f99d15 100644
--- a/templates/corrections-overview.hamlet
+++ b/templates/corrections-overview.hamlet
@@ -56,8 +56,10 @@
$# Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table
$forall shn <- orderedSheetNames
- #{shn}
- $# ^{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}
|
| _{MsgNrSubmissionsTotal}
| _{MsgNrSubmissionsNotCorrected}
diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet
index 6a0d8321e..d2d92be3c 100644
--- a/templates/exam-show.hamlet
+++ b/templates/exam-show.hamlet
@@ -24,7 +24,7 @@ $maybe Entity _ ExamResult{examResultResult} <- result
$maybe desc <- examDescription
#{desc}
-
+
$if not examVisible
@@ -84,7 +84,7 @@ $maybe desc <- examDescription
$maybe registerWdgt <- registerWidget
- _{MsgExamRegistration}
- ^{registerWdgt}
-
+
$if not (null occurrences)
@@ -124,7 +124,7 @@ $if not (null occurrences)
$if occurrenceAssignmentsShown
$if registered
- #{fontAwesomeIcon "check"}
+ #{iconOK}
$if gradingShown && not (null parts)
@@ -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
diff --git a/templates/widgets/alerts/alerts.hamlet b/templates/widgets/alerts/alerts.hamlet
index 4527e62d3..dca147265 100644
--- a/templates/widgets/alerts/alerts.hamlet
+++ b/templates/widgets/alerts/alerts.hamlet
@@ -1,10 +1,9 @@
$newline never
- $forall (status, msg) <- mmsgs
- $with status2 <- bool status "info" (status == "")
-
-
-
-
- #{msg}
+ $forall Message{..} <- mmsgs
+ | |