fradrive-old/src/Handler/Utils/Widgets.hs

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 :: HasRoute UniWorX url => Widget -> url -> Widget
simpleLink lbl url = do
  isAuth <- hasReadAccessTo $ urlRoute url
  if | isAuth -> do
         tUrl <- toTextUrl url
         [whamlet|
           $newline never
           <a href=#{tUrl}>
             ^{lbl}
           |]
     | otherwise -> lbl

simpleLinkI :: (RenderMessage UniWorX msg, HasRoute UniWorX url) => msg -> url -> Widget
simpleLinkI = simpleLink . i18n

-- | 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|_{MsgUtilEditedBy usr ft}|]

boolHeat :: Bool -- ^ @isHot@
         -> Milli
boolHeat = bool 0 1

heat :: ( Real a, Real b )
     => a -> b -> Milli
-- ^ Distinguishes @full@, zero is mapped to 1, @full@ is mapped to 0
heat (realToFrac -> full) (realToFrac -> achieved)
  = fromRational $ cutOffCoPercent 0.3 (full^2) (achieved^2)

invHeat :: ( Real a, Real b )
        => a -> b -> Milli
-- ^ Distinguishes @full@, zero is mapped to 0, @full@ is mapped to 1
invHeat full achieved = 1 - heat full achieved

coHeat :: ( Real a, Real b)
       => a -> b -> Milli
-- ^ Distinguishes zero, zero is mapped to 1, @full@ is mapped to 0
coHeat full achieved = 1 - invCoHeat full achieved

invCoHeat :: ( Real a, Real b)
          => a -> b -> Milli
-- ^ Distinguishes zero, zero is mapped to 0, @full@ is mapped to 1
invCoHeat (realToFrac -> full) (realToFrac -> achieved)
  = fromRational $ cutOffPercent 0.3 (full^2) (achieved^2)


dualHeat :: ( Real a, Real b, Real c )
         => a -> b -> c -> Milli
-- ^ Distinguishes zero, zero is mapped to 0, @optimal@ is mapped to 1, @full@ is mapped to 2
--
-- Falls back to `invCoHeat` if @full <= optimal@
dualHeat (realToFrac -> optimal) (realToFrac -> full) (realToFrac -> achieved)
  | full <= optimal     =                2 * invCoHeat full    achieved
  | achieved <= optimal =                    invCoHeat optimal achieved
  | otherwise           = fromRational $ 1 + cutOffPercent 0 ((full - optimal) ^ 2) ((achieved - optimal) ^ 2)

dualCoHeat :: ( Real a, Real b, Real c )
           => a -> b -> c -> Milli
-- ^ Distinguishes @full@, zero is mapped to 0, @optimal@ is mapped to 1, @full@ is mapped to 2
--
-- Falls back to `invHeat` if @full <= optimal@
dualCoHeat (realToFrac -> optimal) (realToFrac -> full) (realToFrac -> achieved)
  | full <= optimal     =                2 * invHeat full    achieved
  | achieved <= optimal = fromRational $     cutOffPercent 0 (optimal ^ 2) (achieved ^ 2)
  | otherwise           =                1 + invHeat (full - optimal) (achieved - optimal)

invDualHeat :: ( Real a, Real b, Real c )
            => a -> b -> c -> Milli
-- ^ Distinguishes zero, zero is mapped to 2, @optimal@ is mapped to 1, @full@ is mapped to 0
invDualHeat optimal full achieved = 2 - dualHeat optimal full achieved

invDualCoHeat :: ( Real a, Real b, Real c )
              => a -> b -> c -> Milli
-- ^ Distinguishes @full@, zero is mapped to 2, @optimal@ is mapped to 1, @full@ is mapped to 0
invDualCoHeat optimal full achieved = 2 - dualCoHeat optimal full achieved


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


roomReferenceWidget :: RoomReference -> Widget
roomReferenceWidget RoomReferenceSimple{..} = toWidget roomRefText
roomReferenceWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-reference/link")
  where
    linkText = uriToString id roomRefLink mempty
    instrModal = modal (i18n MsgRoomReferenceLinkInstructions) $ Right $(widgetFile "widgets/room-reference/link-instructions-modal")