Intl.hs

module Miso.Fluent.Intl where

import Data.Char (isAlpha, toLower)
import Data.Function ((&))
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Maybe (fromMaybe, isJust)
import Data.Scientific (toRealFloat)
import Data.String (IsString)
import Data.Text qualified as Text
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import Language.Fluent
    ( Digits (..)
    , NumberOptions (..)
    , Style (..)
    , TimeOptions (..)
    , Width (..)
    )
import Language.Fluent.Locale qualified as Fluent
import Language.Fluent.Number qualified as Number
import Language.Fluent.Plural qualified as Plural
import Language.Fluent.Time qualified as Time
import Miso.FFI.QQ (js)
import Miso.JSON (Pair, Value, (.=))
import Miso.JSON qualified as JSON
import Miso.Prelude
import Miso.String (FromMisoString, ToMisoString)
import System.IO.Unsafe (unsafePerformIO)
import Text.Read (readMaybe)

-- | A BCP 47 language tag (e.g. @"en-GB"@ or @"de-CH"@).
newtype Locale = Locale MisoString
    deriving newtype
        ( Eq
        , Ord
        , Show
        , IsString
        , ToMisoString
        , FromMisoString
        , ToJSVal
        , FromJSVal
        )

instance Fluent.Locale Locale where
    fromCode code =
        unsafePerformIO
            [js|
              try {
                return Intl.DateTimeFormat.supportedLocalesOf(
                  [${code}],
                  { localeMatcher: "lookup" },
                )[0] ?? "";
              } catch {
                return "";
              }
            |]
            & \case
                "" -> Nothing
                code' -> Just code'

    toCode (Locale it) = fromMisoString it

    displayLanguage (Locale a) (Locale b) =
        case unsafePerformIO
            [js|
                  try {
                    const { language } = new Intl.Locale(${a});
                    return new Intl.DisplayNames([${b}], { type: "language" }).of(language) ?? "";
                  } catch {
                    return "";
                  }
                |] of
            "" -> Nothing
            name -> Just name

    capitalise (Locale l) t =
        unsafePerformIO
            [js|
              try {
                return ${t}.replace(/^./u, (first) => first.toLocaleUpperCase(${l}));
              } catch {
                return ${t};
              }
            |]

    pluralCategory locale value options =
        unsafePerformIO
            . pluralRules locale (JSON.object $ "type" .= kind : digits options)
            $ toRealFloat value
      where
        kind = toMisoString . fmap toLower . show $ options.form

    formatNumber locales value options =
        maybe (Left "could not format number") (Right . fromMisoString)
            . unsafePerformIO
            . numberFormat locales (JSON.object $ style <> digits options)
            $ toRealFloat value
      where
        style = case options.style of
            Decimal -> []
            Percent -> ["style" .= ("percent" :: MisoString)]
            Currency code ->
                [ "style" .= ("currency" :: MisoString)
                , "currency" .= (toMisoString . Text.filter isAlpha) code
                , "currencyDisplay" .= toMisoString (toLower <$> show options.currencyDisplay)
                ]
            Unit unit ->
                [ "style" .= ("unit" :: MisoString)
                , "unit" .= toMisoString (Number.unitIdentifier unit)
                , "unitDisplay" .= toMisoString (toLower <$> show options.unitDisplay)
                ]

    formatTime locales dateTime options =
        maybe (Left "could not format time") (Right . fromMisoString)
            . unsafePerformIO
            . dateTimeFormat locales options'
            $ millisecondsSinceEpoch dateTime
      where
        options' :: Value
        options' =
            JSON.object
                $ ["timeZone" .= toMisoString options.timeZone]
                <> ["hour12" .= it | Just it <- [options.hour12]]
                <> fmap field (Time.fields options)

        field :: (Char, Either Digits Width) -> Pair
        field (symbol, written) = name symbol .= toMisoString (toLower <$> either show show written)

        name :: Char -> MisoString
        name 'G' = "era"
        name 'y' = "year"
        name 'M' = "month"
        name 'd' = "day"
        name 'E' = "weekday"
        name 'm' = "minute"
        name 's' = "second"
        name 'z' = "timeZoneName"
        name _ = "hour"

        millisecondsSinceEpoch :: UTCTime -> Double
        millisecondsSinceEpoch = (1000 *) . realToFrac . utcTimeToPOSIXSeconds

digits :: NumberOptions -> [Pair]
digits options =
    ["minimumIntegerDigits" .= options.minimumIntegerDigits | options.minimumIntegerDigits > 1]
        <> ["useGrouping" .= False | not options.useGrouping]
        <> precision
  where
    precision
        | Just (least, most) <- Number.significantDigits options =
            [ "minimumSignificantDigits" .= least
            , "maximumSignificantDigits" .= most
            ]
        | options.minimumFractionDigits > 0 || isJust options.maximumFractionDigits =
            [ "minimumFractionDigits" .= atLeast
            , "maximumFractionDigits" .= atMost
            ]
        | otherwise = []
    (atLeast, atMost) = Number.fractionDigits options

instance ToJSVal (NonEmpty Locale) where
    toJSVal = JSON.toJSVal_Value . JSON.toJSON . fmap (toMisoString @Locale) . NonEmpty.toList

numberFormat :: NonEmpty Locale -> Value -> Double -> IO (Maybe MisoString)
numberFormat locales value amount = do
    locale <- toJSVal locales
    options <- JSON.toJSVal_Value value
    [js|
      try {
        return new Intl.NumberFormat(${locale}, ${options}).format(${amount});
      } catch {
        return null;
      }
    |]

pluralRules :: Locale -> Value -> Double -> IO Plural.Category
pluralRules locale value amount = do
    options <- JSON.toJSVal_Value value
    [js|
      return new Intl.PluralRules(${locale}, ${options}).select(${amount});
    |]

instance FromJSVal Plural.Category where
    fromJSVal = fmap (readMaybe =<<) . fromJSVal
    fromJSValUnchecked = fmap (fromMaybe Plural.Other) . fromJSVal

dateTimeFormat :: NonEmpty Locale -> Value -> Double -> IO (Maybe MisoString)
dateTimeFormat locales value epoch = do
    locale <- toJSVal locales
    options <- JSON.toJSVal_Value value
    [js|
      try {
        return new Intl.DateTimeFormat(${locale}, ${options}).format(new Date(${epoch}));
      } catch {
        return null;
      }
    |]

-- | The IANA time zone the browser is set to, e.g. @"Europe/Zurich"@.
localTimeZone :: IO MisoString
localTimeZone = [js| return Intl.DateTimeFormat().resolvedOptions().timeZone; |]