119 lines
4.3 KiB
Haskell
119 lines
4.3 KiB
Haskell
module Handler.Utils.Widgets where
|
|
|
|
import Import
|
|
import qualified Data.Text as T
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Text.Hamlet (shamletFile)
|
|
|
|
import Handler.Utils.DateTime
|
|
|
|
import qualified Data.Char as Char
|
|
|
|
|
|
---------
|
|
-- Simple utilities for consistent display
|
|
-- Please use these throughout, to ensure that users have a consistent experience
|
|
|
|
tidFromText :: Text -> Maybe TermId
|
|
tidFromText = fmap TermKey . maybeRight . termFromText
|
|
|
|
-- | Display given UTCTime and maybe an invisible icon if it is in the future
|
|
--
|
|
-- Also see `Handler.Utils.Table.Cells.dateTimeCellVisible` for a similar function (in case of refactoring)
|
|
visibleUTCTime :: SelDateTimeFormat -> UTCTime -> Widget
|
|
visibleUTCTime dtf t = do
|
|
let timeStampWgt = formatTimeW dtf t
|
|
now <- liftIO getCurrentTime
|
|
if now >= t
|
|
then timeStampWgt
|
|
else $(widgetFile "widgets/date-time/yet-invisible")
|
|
|
|
|
|
-- | Simple link to a known route
|
|
simpleLink :: Widget -> Route UniWorX -> Widget
|
|
simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]
|
|
|
|
simpleLinkI :: SomeMessage UniWorX -> Route UniWorX -> Widget
|
|
simpleLinkI lbl url = [whamlet|<a href=@{url}>_{lbl}|]
|
|
|
|
-- | toWidget-Version of @nameHtml@, for convenience
|
|
nameWidget :: Text -- ^ userDisplayName
|
|
-> Text -- ^ userSurname
|
|
-> Widget
|
|
nameWidget displayName surname = toWidget $ nameHtml displayName surname
|
|
|
|
-- | toWidget-Version of @nameEmailHtml@, for convenience
|
|
nameEmailWidget :: UserEmail -- ^ userEmail
|
|
-> Text -- ^ userDisplayName
|
|
-> Text -- ^ userSurname
|
|
-> Widget
|
|
nameEmailWidget email displayName surname = toWidget $ nameEmailHtml email displayName surname
|
|
|
|
-- | uncurried Version for @nameEmailWidget@ needed in hamlet, where TH cannot be used
|
|
nameEmailWidget' :: (UserEmail, Text, Text)-> Widget
|
|
nameEmailWidget' = $(uncurryN 3) nameEmailWidget
|
|
|
|
-- | Show user's displayName, highlighting the surname if possible.
|
|
-- Otherwise appends the surname in parenthesis
|
|
nameHtml :: Text -> Text -> Html
|
|
nameHtml displayName surname
|
|
| null surname = toHtml displayName
|
|
| otherwise = case reverse $ T.splitOn surname displayName of
|
|
[_notContained] -> [shamlet|$newline never
|
|
#{displayName} (
|
|
<b .surname>#{surname}
|
|
)|]
|
|
(suffix:prefixes) ->
|
|
let prefix = T.intercalate surname $ reverse prefixes
|
|
in [shamlet|$newline never
|
|
#{prefix}
|
|
<b .surname>#{surname}
|
|
#{suffix}
|
|
|]
|
|
[] -> error "Data.Text.splitOn returned empty list in violation of specification."
|
|
|
|
-- | Like nameHtml just show a users displayname with hightlighted surname,
|
|
-- but also wrap the name with a mailto-link
|
|
nameEmailHtml :: UserEmail -> Text -> Text -> Html
|
|
nameEmailHtml email displayName surname =
|
|
wrapMailto email $ nameHtml displayName surname
|
|
|
|
-- | Wrap mailto around given Html using single hamlet-file for consistency
|
|
wrapMailto :: UserEmail -> Html -> Html
|
|
wrapMailto (CI.original -> email) linkText
|
|
| null email = linkText
|
|
| otherwise = $(shamletFile "templates/widgets/link-email.hamlet")
|
|
|
|
-- | Just show an email address in a standard way, for convenience inside hamlet files.
|
|
mailtoHtml :: UserEmail -> Html
|
|
mailtoHtml email = wrapMailto email $(shamletFile "templates/widgets/email.hamlet")
|
|
|
|
-- | Generic i18n text for "edited at sometime by someone"
|
|
editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget
|
|
editedByW fmt tm usr = do
|
|
ft <- handlerToWidget $ formatTime fmt tm
|
|
[whamlet|_{MsgEditedBy usr ft}|]
|
|
|
|
heat :: Integral a => a -> a -> Double
|
|
heat (toInteger -> full) (toInteger -> achieved)
|
|
= roundToDigits 3 $ cutOffPercent 0.3 (fromIntegral full^2) (fromIntegral achieved^2)
|
|
|
|
i18n :: forall m msg.
|
|
( MonadWidget m
|
|
, RenderMessage (HandlerSite m) msg
|
|
) => msg -> m ()
|
|
i18n = toWidget . (SomeMessage :: msg -> SomeMessage (HandlerSite m))
|
|
|
|
|
|
examOccurrenceMappingDescriptionWidget :: ExamOccurrenceRule -> Set ExamOccurrenceMappingDescription -> Widget
|
|
examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets/exam-occurrence-mapping-description")
|
|
where
|
|
titleCase :: [CI Char] -> String
|
|
titleCase = over _head Char.toUpper . map CI.foldedCase
|
|
doPrefix
|
|
| ExamRoomMatriculation <- rule
|
|
= False
|
|
| otherwise
|
|
= True
|