fluent-icu-1.0.0: src/Language/Fluent/ICU.hs
{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
-- |
-- Module : Language.Fluent.ICU
-- Copyright : (c) 2026 Institute for Digital Autonomy
-- License : EUPL-1.2
-- Maintainer : IDA
--
-- <https://projectfluent.org Project Fluent> localisation backed by
-- <https://unicode-org.github.io/icu/ ICU> using the
-- <https://hackage.package.org/package/text-icu text-icu> library.
--
-- This module re-exports everything needed to translate Fluent messages.
--
-- = Quickstart
--
-- == 1. Parsing resources
--
-- Embed Fluent resources at compile time using the 'fluent' quasi-quoter:
--
-- >>> :{
-- let resource =
-- [fluent|
-- welcome = Welcome back!
-- greeting = Hello, { $name }! You have { $count } new messages.
-- unread-emails =
-- { $count ->
-- [one] You have one unread email.
-- *[other] You have several unread emails.
-- }
-- amount = { $amount }
-- price = { NUMBER($amount, currency: "EUR", currencyDisplay: "name") }
-- temperature = { NUMBER($degrees, unit: "celsius", unitDisplay: "long") }
-- |]
-- :}
--
-- Or parse Fluent source at runtime with 'parseResource':
--
-- > resource <- either fail pure . parseResource =<< Text.readFile "resource.ftl"
--
-- == 2. Building bundles
--
-- Combine 'Resource's and 'Locale's into a 'Bundle' using 'bundle':
--
-- >>> let english = bundle @LocaleName (pure "en-GB") [resource]
-- >>> let german = bundle @LocaleName (pure "de-CH") [resource]
--
-- == 3. Translating messages
--
-- Translate messages with 'translate':
--
-- >>> translate "welcome" english :: Either String Text
-- Right "Welcome back!"
--
-- Pass parameters as name-value tuples:
--
-- >>> translate "unread-emails" ("count", value @Int 1) english :: Either String Text
-- Right "You have one unread email."
-- >>> translate "unread-emails" ("count", value @Int 5) english :: Either String Text
-- Right "You have several unread emails."
--
-- You can chain multiple arguments and configure Unicode isolation marks using 'UseIsolating':
--
-- >>> translate "greeting" ("name", value @Text "Ann") ("count", value @Int 3) (UseIsolating False) english :: Either String Text
-- Right "Hello, Ann! You have 3 new messages."
--
-- == 4. Formatting numbers, currencies, and units
--
-- Number formatting adapts to the target locale:
--
-- >>> translate "amount" ("amount", value @Int 1234567) english :: Either String Text
-- Right "1,234,567"
-- >>> translate "amount" ("amount", value @Int 1234567) german :: Either String Text
-- Right "1'234'567"
-- >>> translate "price" ("amount", value @Double 1234.5) english :: Either String Text
-- Right "1,234.50 euros"
-- >>> translate "price" ("amount", value @Double 1234.5) german :: Either String Text
-- Right "1'234.50 Euro"
-- >>> translate "temperature" ("degrees", value @Int 21) english :: Either String Text
-- Right "21 degrees Celsius"
-- >>> translate "temperature" ("degrees", value @Int 21) german :: Either String Text
-- Right "21 Grad Celsius"
--
-- You can pass formatting options directly via structured values:
--
-- >>> translate "amount" ("amount", NumberValue 1234.5 numberOptions{style = Currency "EUR", currencyDisplay = Name}) english :: Either String Text
-- Right "1,234.50 euros"
-- >>> translate "amount" ("amount", NumberValue 21 numberOptions{style = Unit "metre-per-second", unitDisplay = Short}) english :: Either String Text
-- Right "21 m/s"
module Language.Fluent.ICU
( -- * Re-exports
module Data.Text.ICU
, module Language.Fluent
)
where
import Control.Exception (SomeException, evaluate, try)
import Control.Monad (when)
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import Data.ByteString qualified as ByteString
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Maybe (fromMaybe)
import Data.Scientific (FPFormat (Fixed), Scientific, formatScientific)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Text.ICU (LocaleName (..))
import Data.Text.ICU.Calendar (Calendar)
import Data.Text.ICU.Calendar qualified as ICU
import Data.Text.ICU.DateFormatter qualified as ICU
import Data.Text.ICU.Types qualified as ICU
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import Foreign.C.String (CString, peekCString, peekCStringLen, withCString)
import Foreign.C.Types (CDouble (..), CInt (..))
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Marshal.Array (withArrayLen)
import Foreign.Marshal.Utils (withMany)
import Foreign.Ptr (Ptr, nullPtr)
import Language.Fluent
import Language.Fluent.Number qualified as Number
import Language.Fluent.Plural qualified as Plural
import Language.Fluent.Time qualified as Time
import System.IO.Unsafe (unsafePerformIO)
import Text.Read (readMaybe)
import Prelude
instance Locale LocaleName where
fromCode = negotiateLocale . pure . ICU.Locale . Text.unpack
toCode (ICU.Locale name) = Text.pack name
toCode _ = ""
displayLanguage a b = unsafePerformIO $
withLocaleName a \source ->
withLocaleName b \target ->
allocaBytes capacity \name -> do
written <- fluentGetDisplayLanguage source target name (fromIntegral capacity)
if written < 0
then pure Nothing
else Just . Text.decodeUtf8 <$> ByteString.packCStringLen (name, fromIntegral written)
where
capacity = 256 :: Int
capitalise l text = unsafePerformIO $
withLocaleName l \locale ->
ByteString.useAsCStringLen utf8 \(source, sourceLength) ->
allocaBytes capacity \out -> do
written <-
fluentFormatTitlecase locale source (fromIntegral sourceLength) out (fromIntegral capacity)
if written < 0
then pure text
else Text.decodeUtf8 <$> ByteString.packCStringLen (out, fromIntegral written)
where
utf8 = Text.encodeUtf8 text
capacity = 2 * ByteString.length utf8 + 16
pluralCategory locale value options = unsafePerformIO $
withLocaleName locale \name ->
withUtf8Text (Number.skeleton options) \skeleton ->
ByteString.useAsCStringLen (exactDecimal value) \(decimal, decimalLength) ->
allocaBytes capacity \keyword -> do
written <-
fluentGetPluralKeyword
name
ordinal
skeleton
decimal
(fromIntegral decimalLength)
keyword
(fromIntegral capacity)
if written < 0
then pure Plural.Other
else fromMaybe Plural.Other . readMaybe <$> peekCStringLen (keyword, fromIntegral written)
where
capacity = 32 :: Int
ordinal = case options.form of
Plural.Cardinal -> 0 :: CInt
Plural.Ordinal -> 1
formatNumber locales value options = unsafePerformIO $
withLocaleName locale \name ->
withUtf8Text skeleton \skel ->
ByteString.useAsCStringLen (exactDecimal value) \(decimal, decimalLength) ->
let capacity = max 256 $ decimalLength * 2 + 64
in allocaBytes capacity \out -> do
written <-
fluentFormatDecimal
name
skel
decimal
(fromIntegral decimalLength)
out
(fromIntegral capacity)
if written < 0
then Left . ("NUMBER: " <>) <$> icuErrorMessage written
else Right . Text.decodeUtf8 <$> ByteString.packCStringLen (out, fromIntegral written)
where
locale = fromMaybe (NonEmpty.head locales) $ negotiateLocale locales
skeleton = Number.skeleton options
formatTime locales dateTime options =
unsafePerformIO . fmap (first show) . try @SomeException $ do
pattern <-
withLocaleName locale \name ->
withUtf8Text skeleton \wanted ->
allocaBytes capacity \ptr -> do
written <- fluentResolveDatePattern name wanted ptr (fromIntegral capacity)
if written < 0
then pure skeleton
else Text.decodeUtf8 <$> ByteString.packCStringLen (ptr, fromIntegral written)
formatter <- ICU.patternDateFormatter pattern locale options.timeZone
calendar <- ICU.calendar options.timeZone locale ICU.TraditionalCalendarType
setMillis calendar $ millisecondsSinceEpoch dateTime
evaluate $ ICU.formatCalendar formatter calendar
where
capacity = 256 :: Int
locale = fromMaybe (NonEmpty.head locales) $ negotiateLocale locales
skeleton = Time.skeleton options
millisecondsSinceEpoch :: UTCTime -> Double
millisecondsSinceEpoch = (* 1000) . realToFrac . utcTimeToPOSIXSeconds
setMillis :: Calendar -> Double -> IO ()
setMillis calendar ms = do
ok <- withForeignPtr calendar.calendarForeignPtr \pointer ->
fluentSetCalendarTimeMs pointer $ realToFrac ms
when (ok < 0) $ fail "fluentSetCalendarTimeMs failed"
-- | The name of the ICU error a negated 'fluentFormatDecimal' / 'fluentGetPluralKeyword'
-- result encodes, e.g. @U_ILLEGAL_ARGUMENT_ERROR@.
icuErrorMessage :: CInt -> IO String
icuErrorMessage written = peekCString =<< fluentErrorName (negate written)
-- | The exact decimal representation of a 'Scientific' value, as UTF-8 bytes, fit to pass
-- to ICU's decimal-string number-formatting entry points. Never round-trips through a
-- floating-point 'Double', unlike 'Data.Scientific.toRealFloat', so it can't lose precision
-- for large or high-precision values.
exactDecimal :: Scientific -> ByteString
exactDecimal = Text.encodeUtf8 . Text.pack . formatScientific Fixed Nothing
-- | Resolve a locale preference list to the best-supported locale ICU has data for.
-- Matches how @Intl@ (ECMA-402) handles its locale-list arguments.
-- 'Nothing' if none of the preferences are recognised at all.
negotiateLocale :: NonEmpty LocaleName -> Maybe LocaleName
negotiateLocale preferences = unsafePerformIO $
withMany withLocaleName (NonEmpty.toList preferences) \accept ->
withArrayLen accept \count array ->
allocaBytes capacity \out -> do
written <- fluentNegotiateSupportedLocale array (fromIntegral count) out (fromIntegral capacity)
if written < 0
then pure Nothing
else Just . ICU.Locale <$> peekCStringLen (out, fromIntegral written)
where
capacity = 256 :: Int
-- | Pass a locale's name to a foreign function. Matches 'Data.Text.ICU.Internal.withLocaleName'.
withLocaleName :: LocaleName -> (CString -> IO a) -> IO a
withLocaleName ICU.Current = ($ nullPtr)
withLocaleName ICU.Root = withCString ""
withLocaleName (ICU.Locale name) = withCString name
withUtf8Text :: Text -> (CString -> IO a) -> IO a
withUtf8Text = ByteString.useAsCString . Text.encodeUtf8
foreign import ccall unsafe "fluent_get_display_language"
fluentGetDisplayLanguage :: CString -> CString -> CString -> CInt -> IO CInt
foreign import ccall unsafe "fluent_format_titlecase"
fluentFormatTitlecase :: CString -> CString -> CInt -> CString -> CInt -> IO CInt
foreign import ccall unsafe "fluent_get_plural_keyword"
fluentGetPluralKeyword
:: CString -> CInt -> CString -> CString -> CInt -> CString -> CInt -> IO CInt
foreign import ccall unsafe "fluent_format_decimal"
fluentFormatDecimal :: CString -> CString -> CString -> CInt -> CString -> CInt -> IO CInt
foreign import ccall unsafe "fluent_resolve_date_pattern"
fluentResolveDatePattern :: CString -> CString -> CString -> CInt -> IO CInt
foreign import ccall unsafe "fluent_set_calendar_time_ms"
fluentSetCalendarTimeMs :: Ptr ICU.UCalendar -> CDouble -> IO CInt
foreign import ccall unsafe "fluent_negotiate_supported_locale"
fluentNegotiateSupportedLocale :: Ptr CString -> CInt -> CString -> CInt -> IO CInt
foreign import ccall unsafe "fluent_error_name"
fluentErrorName :: CInt -> IO CString