-- SPDX-FileCopyrightText: 2022-2025 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

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
import qualified Data.HashMap.Strict as Aeson -- ON UPDATE replace with: import qualified Data.Aeson.KeyMap as Aeson
import Data.Scientific

---------
-- 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
  let route = urlRoute url
  isAuth <- liftHandler . $cachedHereBinary route $ hasReadAccessTo route
  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

userWidget :: HasUser c => c -> Widget
userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname)

userIdWidget :: UserId -> Widget
userIdWidget uid = maybeM (msg2widget MsgUserUnknown) userWidget (liftHandler $ runDBRead $ get uid)

linkUserWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> Entity User -> Widget
linkUserWidget lnk (Entity uid usr) = do
  uuid <- encrypt uid
  simpleLink (userWidget usr) (lnk uuid)

-- | like linkUserWidget, but on Id only. Requires DB access, use with caution
linkUserIdWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> UserId -> Widget
linkUserIdWidget lnk uid = maybeM (msg2widget MsgUserUnknown) (linkUserWidget lnk . Entity uid) (liftHandler $ runDBRead $ get uid)

userEmailWidget :: HasUser c => c -> Widget
userEmailWidget x = nameEmailWidget (x ^. _userDisplayEmail) (x ^. _userDisplayName) (x ^. _userSurname)

-- | 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]
        | (suffix:prefixes) <- reverse $ T.splitOn (T.toTitle surname) (T.toTitle displayName), notNull prefixes ->
          let prefix = T.intercalate surname $ reverse prefixes
          in [shamlet|$newline never
                #{prefix} #
                <b .surname>#{surname}
                #{withLeadingSpace suffix}
              |]
        | (suffix:prefixes) <- reverse $ T.splitOn (fullyNormalize surname) (fullyNormalize displayName), notNull prefixes ->
          let prefix = T.intercalate surname $ reverse prefixes
          in [shamlet|$newline never
                #{prefix} #
                <b .surname>#{surname}
                #{withLeadingSpace suffix}
              |]
        | otherwise -> [shamlet|$newline never
                            #{displayName} (
                            <b .surname>#{surname}
                            )|]
      (suffix:prefixes) ->
        let prefix = T.intercalate surname $ reverse prefixes
        in [shamlet|$newline never
              #{prefix}
              <b .surname>#{surname}
              #{withLeadingSpace suffix}
            |]
      [] -> error "Data.Text.splitOn returned empty list in violation of specification."
  where
    fullyNormalize :: Text -> Text
    fullyNormalize = T.toTitle . T.unwords . map text2asciiAlphaNum . T.words

    withLeadingSpace :: Text -> Text
    withLeadingSpace t
      | T.null t                    = t
      | Just (' ', _) <- T.uncons t = t
      | otherwise                   = T.cons ' ' t

nameHtml' :: HasUser u => u -> Html
nameHtml' u = nameHtml (u ^. _userDisplayName) (u ^. _userSurname)

-- | 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}|]


-- | like `modal`, but only conditionally displays the modal link only after checking access rights. WARNING: this might be too slow for large dbTable. Use `modalAccessCheckOnClick` instead
modalAccess :: Widget -> Widget -> Bool -> Route UniWorX -> Widget
modalAccess wdgtNo wdgtYes writeAccess route = do
  authOk <- liftHandler . $cachedHereBinary (route, writeAccess) $ bool hasReadAccessTo hasWriteAccessTo writeAccess route
  if authOk
    then modal wdgtYes (Left $ SomeRoute route)
    else       wdgtNo

-- also see Handler.Utils.Table.Cells.companyCell
companyWidget :: Bool -> (CompanyShorthand, CompanyName, Bool) -> Widget
companyWidget = companyWidget' False

companyWidget'  :: Bool -> Bool -> (CompanyShorthand, CompanyName, Bool) -> Widget
companyWidget' useShort isPrimary (csh, cname, isSupervisor)
  | isPrimary, isSupervisor = simpleLink (toWgt $ name <>                   iconSupervisor) curl
  | isPrimary               = simpleLink (toWgt   name                                    ) curl
  |            isSupervisor =             toWgt   name <> simpleLink (toWgt iconSupervisor) curl
  | otherwise               =             toWgt   name
  where
    curl = FirmUsersR csh
    corg = ciOriginal $ bool cname csh useShort
    name
      | isSupervisor = text2markup (corg <> " ")
      | otherwise    = text2markup  corg

widgetMailPrefPin :: HasUser u => u -> Widget
widgetMailPrefPin usr = if not prefPost && hasPin
    then [whamlet|^{modWgt} ^{pinWgt}|]
    else modWgt
  where
    prefPost :: Bool   =         usr ^. _userPrefersPostal
    hasPin   :: Bool   = isJust (usr ^. _userPinPassword)
    modWgt   :: Widget = toWidget $ iconLetterOrEmail prefPost
    pinWgt   :: Widget = toWidget   iconPinProtect

---------------------
-- Status Tooltips --
---------------------

-- | generate a generic colored icon to display success or failure to user
mkErrorFlag :: Handler (Maybe Bool -> Widget)
mkErrorFlag = do
  -- we abuse messageTooltip for colored icons here
  msgSuccessTooltip <- messageI Success MsgMessageSuccess
  msgWarningTooltip <- messageI Warning MsgMessageWarning
  msgErrorTooltip   <- messageI Error   MsgMessageError
  let flagError Nothing       = messageTooltip msgWarningTooltip
      flagError (Just False)  = messageTooltip msgErrorTooltip
      flagError (Just True)   = messageTooltip msgSuccessTooltip
  return flagError


----------
-- HEAT --
----------


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


-----------
-- COLOR --
-----------

--  TODO: someone with frontend capabilities should get rid of class tooltip__handle and check theme consistent colors

statusHtml :: MessageStatus -> Html -> Html
statusHtml sts wgt =
  [shamlet|
    <span .tooltip__handle .#{statusToUrgencyClass sts}>
      ^{wgt}
  |]

statusWidget :: MessageStatus -> Widget -> Widget
statusWidget sts wgt =
  [whamlet|
    <span .tooltip__handle .#{statusToUrgencyClass sts}>
      ^{wgt}
  |]

heatedWidget :: Milli -> Widget -> Widget
heatedWidget ht wgt =
  [whamlet|
    <span .heated style="--hotness: #{ht}">
      ^{wgt}
  |]


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{..} = msg2widget $ MsgRoomReferenceSimpleAt 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")

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


----------
-- JSON --
----------

-- Data.Aeson.Encode.Pretty.encodePretty did not render in Html properly, hence jsonWidget
jsonWidget :: ToJSON a => a -> Widget
jsonWidget x = jsonWidgetAux $ toJSON x
  where
    jsonWidgetAux :: Value -> Widget
    jsonWidgetAux  Null       = [whamlet|Null|]
    jsonWidgetAux (Bool   b)  = toWidget $ boolSymbol b
    jsonWidgetAux (String s)  = [whamlet|#{s}|]
    jsonWidgetAux (Number n)
      | isInteger n           = [whamlet|#{formatScientific Fixed   (Just 0) n}|]
      | otherwise             = [whamlet|#{formatScientific Generic Nothing  n}|]
    jsonWidgetAux (Array  l)
      | 1 >= length l = foldMap jsonWidgetAux l -- empty arrays don't show
      | otherwise     =
        [whamlet|
          <ul>
            $forall x <- sort l
              <li>^{jsonWidgetAux x}
        |]
    jsonWidgetAux (Object o)  = case Aeson.toList o of -- toAscList not supported
      [ ]     -> mempty             -- empty objects don't show
      [(_,v)] -> jsonWidgetAux v
      r -> [whamlet|
          <dl .deflist>
            $forall (k,v) <- sort r
              <dt .deflist__dt>#{k}
              <dd .deflist__dd>^{jsonWidgetAux v}
        |]
