diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), +and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## [1.0.0] - 2026-10-01 + +### Added + +- Initial release. diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,287 @@ + EUROPEAN UNION PUBLIC LICENCE v. 1.2 + EUPL © the European Union 2007, 2016 + +This European Union Public Licence (the ‘EUPL’) applies to the Work (as defined +below) which is provided under the terms of this Licence. Any use of the Work, +other than as authorised under this Licence is prohibited (to the extent such +use is covered by a right of the copyright holder of the Work). + +The Work is provided under the terms of this Licence when the Licensor (as +defined below) has placed the following notice immediately following the +copyright notice for the Work: + + Licensed under the EUPL + +or has expressed by any other means his willingness to license under the EUPL. + +1. Definitions + +In this Licence, the following terms have the following meaning: + +- ‘The Licence’: this Licence. + +- ‘The Original Work’: the work or software distributed or communicated by the + Licensor under this Licence, available as Source Code and also as Executable + Code as the case may be. + +- ‘Derivative Works’: the works or software that could be created by the + Licensee, based upon the Original Work or modifications thereof. This Licence + does not define the extent of modification or dependence on the Original Work + required in order to classify a work as a Derivative Work; this extent is + determined by copyright law applicable in the country mentioned in Article 15. + +- ‘The Work’: the Original Work or its Derivative Works. + +- ‘The Source Code’: the human-readable form of the Work which is the most + convenient for people to study and modify. + +- ‘The Executable Code’: any code which has generally been compiled and which is + meant to be interpreted by a computer as a program. + +- ‘The Licensor’: the natural or legal person that distributes or communicates + the Work under the Licence. + +- ‘Contributor(s)’: any natural or legal person who modifies the Work under the + Licence, or otherwise contributes to the creation of a Derivative Work. + +- ‘The Licensee’ or ‘You’: any natural or legal person who makes any usage of + the Work under the terms of the Licence. + +- ‘Distribution’ or ‘Communication’: any act of selling, giving, lending, + renting, distributing, communicating, transmitting, or otherwise making + available, online or offline, copies of the Work or providing access to its + essential functionalities at the disposal of any other natural or legal + person. + +2. Scope of the rights granted by the Licence + +The Licensor hereby grants You a worldwide, royalty-free, non-exclusive, +sublicensable licence to do the following, for the duration of copyright vested +in the Original Work: + +- use the Work in any circumstance and for all usage, +- reproduce the Work, +- modify the Work, and make Derivative Works based upon the Work, +- communicate to the public, including the right to make available or display + the Work or copies thereof to the public and perform publicly, as the case may + be, the Work, +- distribute the Work or copies thereof, +- lend and rent the Work or copies thereof, +- sublicense rights in the Work or copies thereof. + +Those rights can be exercised on any media, supports and formats, whether now +known or later invented, as far as the applicable law permits so. + +In the countries where moral rights apply, the Licensor waives his right to +exercise his moral right to the extent allowed by law in order to make effective +the licence of the economic rights here above listed. + +The Licensor grants to the Licensee royalty-free, non-exclusive usage rights to +any patents held by the Licensor, to the extent necessary to make use of the +rights granted on the Work under this Licence. + +3. Communication of the Source Code + +The Licensor may provide the Work either in its Source Code form, or as +Executable Code. If the Work is provided as Executable Code, the Licensor +provides in addition a machine-readable copy of the Source Code of the Work +along with each copy of the Work that the Licensor distributes or indicates, in +a notice following the copyright notice attached to the Work, a repository where +the Source Code is easily and freely accessible for as long as the Licensor +continues to distribute or communicate the Work. + +4. Limitations on copyright + +Nothing in this Licence is intended to deprive the Licensee of the benefits from +any exception or limitation to the exclusive rights of the rights owners in the +Work, of the exhaustion of those rights or of other applicable limitations +thereto. + +5. Obligations of the Licensee + +The grant of the rights mentioned above is subject to some restrictions and +obligations imposed on the Licensee. Those obligations are the following: + +Attribution right: The Licensee shall keep intact all copyright, patent or +trademarks notices and all notices that refer to the Licence and to the +disclaimer of warranties. The Licensee must include a copy of such notices and a +copy of the Licence with every copy of the Work he/she distributes or +communicates. The Licensee must cause any Derivative Work to carry prominent +notices stating that the Work has been modified and the date of modification. + +Copyleft clause: If the Licensee distributes or communicates copies of the +Original Works or Derivative Works, this Distribution or Communication will be +done under the terms of this Licence or of a later version of this Licence +unless the Original Work is expressly distributed only under this version of the +Licence — for example by communicating ‘EUPL v. 1.2 only’. The Licensee +(becoming Licensor) cannot offer or impose any additional terms or conditions on +the Work or Derivative Work that alter or restrict the terms of the Licence. + +Compatibility clause: If the Licensee Distributes or Communicates Derivative +Works or copies thereof based upon both the Work and another work licensed under +a Compatible Licence, this Distribution or Communication can be done under the +terms of this Compatible Licence. For the sake of this clause, ‘Compatible +Licence’ refers to the licences listed in the appendix attached to this Licence. +Should the Licensee's obligations under the Compatible Licence conflict with +his/her obligations under this Licence, the obligations of the Compatible +Licence shall prevail. + +Provision of Source Code: When distributing or communicating copies of the Work, +the Licensee will provide a machine-readable copy of the Source Code or indicate +a repository where this Source will be easily and freely available for as long +as the Licensee continues to distribute or communicate the Work. + +Legal Protection: This Licence does not grant permission to use the trade names, +trademarks, service marks, or names of the Licensor, except as required for +reasonable and customary use in describing the origin of the Work and +reproducing the content of the copyright notice. + +6. Chain of Authorship + +The original Licensor warrants that the copyright in the Original Work granted +hereunder is owned by him/her or licensed to him/her and that he/she has the +power and authority to grant the Licence. + +Each Contributor warrants that the copyright in the modifications he/she brings +to the Work are owned by him/her or licensed to him/her and that he/she has the +power and authority to grant the Licence. + +Each time You accept the Licence, the original Licensor and subsequent +Contributors grant You a licence to their contributions to the Work, under the +terms of this Licence. + +7. Disclaimer of Warranty + +The Work is a work in progress, which is continuously improved by numerous +Contributors. It is not a finished work and may therefore contain defects or +‘bugs’ inherent to this type of development. + +For the above reason, the Work is provided under the Licence on an ‘as is’ basis +and without warranties of any kind concerning the Work, including without +limitation merchantability, fitness for a particular purpose, absence of defects +or errors, accuracy, non-infringement of intellectual property rights other than +copyright as stated in Article 6 of this Licence. + +This disclaimer of warranty is an essential part of the Licence and a condition +for the grant of any rights to the Work. + +8. Disclaimer of Liability + +Except in the cases of wilful misconduct or damages directly caused to natural +persons, the Licensor will in no event be liable for any direct or indirect, +material or moral, damages of any kind, arising out of the Licence or of the use +of the Work, including without limitation, damages for loss of goodwill, work +stoppage, computer failure or malfunction, loss of data or any commercial +damage, even if the Licensor has been advised of the possibility of such damage. +However, the Licensor will be liable under statutory product liability laws as +far such laws apply to the Work. + +9. Additional agreements + +While distributing the Work, You may choose to conclude an additional agreement, +defining obligations or services consistent with this Licence. However, if +accepting obligations, You may act only on your own behalf and on your sole +responsibility, not on behalf of the original Licensor or any other Contributor, +and only if You agree to indemnify, defend, and hold each Contributor harmless +for any liability incurred by, or claims asserted against such Contributor by +the fact You have accepted any warranty or additional liability. + +10. Acceptance of the Licence + +The provisions of this Licence can be accepted by clicking on an icon ‘I agree’ +placed under the bottom of a window displaying the text of this Licence or by +affirming consent in any other similar way, in accordance with the rules of +applicable law. Clicking on that icon indicates your clear and irrevocable +acceptance of this Licence and all of its terms and conditions. + +Similarly, you irrevocably accept this Licence and all of its terms and +conditions by exercising any rights granted to You by Article 2 of this Licence, +such as the use of the Work, the creation by You of a Derivative Work or the +Distribution or Communication by You of the Work or copies thereof. + +11. Information to the public + +In case of any Distribution or Communication of the Work by means of electronic +communication by You (for example, by offering to download the Work from a +remote location) the distribution channel or media (for example, a website) must +at least provide to the public the information requested by the applicable law +regarding the Licensor, the Licence and the way it may be accessible, concluded, +stored and reproduced by the Licensee. + +12. Termination of the Licence + +The Licence and the rights granted hereunder will terminate automatically upon +any breach by the Licensee of the terms of the Licence. + +Such a termination will not terminate the licences of any person who has +received the Work from the Licensee under the Licence, provided such persons +remain in full compliance with the Licence. + +13. Miscellaneous + +Without prejudice of Article 9 above, the Licence represents the complete +agreement between the Parties as to the Work. + +If any provision of the Licence is invalid or unenforceable under applicable +law, this will not affect the validity or enforceability of the Licence as a +whole. Such provision will be construed or reformed so as necessary to make it +valid and enforceable. + +The European Commission may publish other linguistic versions or new versions of +this Licence or updated versions of the Appendix, so far this is required and +reasonable, without reducing the scope of the rights granted by the Licence. New +versions of the Licence will be published with a unique version number. + +All linguistic versions of this Licence, approved by the European Commission, +have identical value. Parties can take advantage of the linguistic version of +their choice. + +14. Jurisdiction + +Without prejudice to specific agreement between parties, + +- any litigation resulting from the interpretation of this License, arising + between the European Union institutions, bodies, offices or agencies, as a + Licensor, and any Licensee, will be subject to the jurisdiction of the Court + of Justice of the European Union, as laid down in article 272 of the Treaty on + the Functioning of the European Union, + +- any litigation arising between other parties and resulting from the + interpretation of this License, will be subject to the exclusive jurisdiction + of the competent court where the Licensor resides or conducts its primary + business. + +15. Applicable Law + +Without prejudice to specific agreement between parties, + +- this Licence shall be governed by the law of the European Union Member State + where the Licensor has his seat, resides or has his registered office, + +- this licence shall be governed by Belgian law if the Licensor has no seat, + residence or registered office inside a European Union Member State. + +Appendix + +‘Compatible Licences’ according to Article 5 EUPL are: + +- GNU General Public License (GPL) v. 2, v. 3 +- GNU Affero General Public License (AGPL) v. 3 +- Open Software License (OSL) v. 2.1, v. 3.0 +- Eclipse Public License (EPL) v. 1.0 +- CeCILL v. 2.0, v. 2.1 +- Mozilla Public Licence (MPL) v. 2 +- GNU Lesser General Public Licence (LGPL) v. 2.1, v. 3 +- Creative Commons Attribution-ShareAlike v. 3.0 Unported (CC BY-SA 3.0) for + works other than software +- European Union Public Licence (EUPL) v. 1.1, v. 1.2 +- Québec Free and Open-Source Licence — Reciprocity (LiLiQ-R) or Strong + Reciprocity (LiLiQ-R+). + +The European Commission may update this Appendix to later versions of the above +licences without producing a new version of the EUPL, as long as they provide +the rights granted in Article 2 of this Licence and protect the covered Source +Code from exclusive appropriation. + +All other changes or additions to this Appendix require the production of a new +EUPL version. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/miso-fluent.cabal b/miso-fluent.cabal new file mode 100644 --- /dev/null +++ b/miso-fluent.cabal @@ -0,0 +1,90 @@ +cabal-version: 3.0 +name: miso-fluent +version: 1.0.0 +synopsis: Translate miso apps with Project Fluent +description: + In-browser localisation backed by + . + +license: EUPL-1.2 +license-file: LICENCE +author: IDA +maintainer: IDA +homepage: https://digital-autonomy.institute +bug-reports: https://issues.digital-autonomy.institute +category: Web, Language +build-type: Simple +extra-doc-files: + CHANGELOG.md + +common common + default-language: Haskell2010 + ghc-options: + -Weverything + -Wno-safe + -Wno-unsafe + -Wno-all-missed-specialisations + -Wno-missing-export-lists + -Wno-missing-import-lists + -Wno-missing-kind-signatures + -Wno-missing-role-annotations + -Wno-missing-safe-haskell-mode + -Wno-orphans + + if (impl(ghcjs) || arch(javascript)) + cpp-options: -DGHCJS_BROWSER + elif arch(wasm32) + cpp-options: -DWASM + else + cpp-options: -DVANILLA + + default-extensions: + BlockArguments + DerivingStrategies + FlexibleInstances + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + NamedFieldPuns + NoImplicitPrelude + OverloadedRecordDot + OverloadedStrings + QuasiQuotes + TypeApplications + TypeOperators + ViewPatterns + + build-depends: + base >=4 && <5, + miso >=1.14 && <1.15, + time >=1.12 && <1.17, + +library + import: common + hs-source-dirs: src + build-depends: + fluent >=1.0 && <1.1, + fluent-syntax >=1.0 && <1.1, + scientific >=0.3 && <0.4, + text >=2.1 && <2.2, + + exposed-modules: + Miso.Fluent + Miso.Fluent.Intl + Miso.Fluent.Parser + +executable miso-fluent-test + import: common + hs-source-dirs: test + main-is: Main.hs + build-depends: + hspec >=2.11 && <2.12, + miso-fluent, + + if (impl(ghcjs) || arch(javascript)) + ld-options: -sEXPORTED_RUNTIME_METHODS=HEAP8 + elif arch(wasm32) + ghc-options: + -no-hs-main + -optl-mexec-model=reactor + "-optl-Wl,--export=hs_start" diff --git a/src/Miso/Fluent.hs b/src/Miso/Fluent.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Fluent.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +-- | +-- Module : Miso.Fluent +-- Copyright : (c) 2026 Institute for Digital Autonomy +-- License : EUPL-1.2 +-- Maintainer : IDA +-- +-- In-browser localisation backed by +-- . +-- +-- 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| +-- > greeting = Hello! +-- > welcome = Welcome, { $name } +-- > |] +-- +-- Or parse Fluent source at runtime from an asynchronous 'getText' request: +-- +-- > getText "/static/en-GB.ftl" [] +-- > (\res -> SetResource $ Fluent.parse Fluent.resource (body res)) +-- > (\err -> SetResource $ Left "Failed to fetch .ftl file") +-- +-- == 2. Building bundles +-- +-- Combine 'Resource's and 'Locale's into a 'Bundle' using 'bundle': +-- +-- > let english = bundle @Locale (pure "en-GB") [resource] +-- +-- == 3. Translating +-- +-- 'translate' is overloaded on its return type, allowing a message to be translated +-- into a plain 'MisoString' or directly into a 'View'. +-- +-- === To 'MisoString' +-- +-- Translate directly against a 'Bundle': +-- +-- > translate "welcome" ("name", "Ann" :: MisoString) (UseIsolating False) english :: Either String MisoString +-- > -- Right "Welcome, Ann" +-- +-- If you request a plain 'MisoString' instead of 'Either', errors are logged to the +-- browser console and the error message is returned as fallback text: +-- +-- > translate "welcome" ("name", "Ann" :: MisoString) english :: MisoString +-- > -- "Welcome, Ann" +-- +-- === To 'View' +-- +-- When returning a 'View', 'translate' automatically retrieves the 'Bundle' from the ambient Miso context, +-- which must implement 'Fluent': +-- +-- > data Context = Context { bundle :: Bundle Locale } +-- > deriving anyclass (Fluent) +-- +-- Render directly to a text node: +-- +-- > greeting :: View Context props model action +-- > greeting = translate "greeting" +-- +-- Pass a continuation to customise element wrapping: +-- +-- > welcome :: View Context props model action +-- > welcome = translate "welcome" ("name", "Ann" :: MisoString) \msg -> +-- > p_ [] [text msg] +-- +-- Or accept an 'Either' in the continuation to handle translation failures explicitly: +-- +-- > welcome :: View Context props model action +-- > welcome = translate "welcome" ("name", "Ann" :: MisoString) \case +-- > Right msg -> p_ [] [text msg] +-- > Left err -> p_ [class_ "error"] [text $ toMisoString err] +module Miso.Fluent + ( Fluent (..) + , Locale (..) + + -- * Re-exports + , module Language.Fluent + ) +where + +import Data.String (IsString (..)) +import Data.Text (Text) +import GHC.Records (HasField) +import Language.Fluent hiding (Locale) +import Miso.Fluent.Intl (Locale (..)) +import Miso.Prelude hiding (context, props) +import Miso.String (FromMisoString (..)) +import Miso.Trace (traceErrorId) + +-- | Types that can supply a translation 'Bundle'. +-- +-- This is usually a context or a model type. +class Fluent f where + getBundle :: f -> Bundle Locale + default getBundle :: (HasField "bundle" f (Bundle Locale)) => f -> Bundle Locale + getBundle = (.bundle) + +instance Fluent (Bundle Locale) where + getBundle = id + +instance FromMisoString SomeValue where + fromMisoStringEither = fmap StringValue . fromMisoStringEither + +instance FromMisoString Reference where + fromMisoStringEither = Right . fromString . fromMisoString + +#ifndef VANILLA +instance Value MisoString where value = value . fromMisoString @Text +#endif + +instance {-# OVERLAPPABLE #-} (Fluent context) => Translate (context -> Either String MisoString) where + translate ref context = toMisoString @Text <$> translate ref (getBundle context) + +instance + (Fluent context, context ~ context', props ~ props', model' ~ model, action ~ action') + => Translate + ((Either String MisoString -> View context' props' model' action') -> View context props model action) + where + translate ref f = withContext \(getBundle -> bundle) -> f $ translate ref bundle + +instance + (Fluent context, context ~ context', props ~ props', model' ~ model, action ~ action') + => Translate + ( (Either String MisoString -> [View context' props' model' action']) + -> View context props model action + ) + where + translate ref f = translate ref $ fragment . f + +instance + (Fluent context, context ~ context', props ~ props', model' ~ model, action ~ action') + => Translate ((MisoString -> [View context' props' model' action']) -> View context props model action) + where + translate ref f = translate ref $ f . either (traceErrorId . toMisoString @String) id + +instance (Fluent context) => Translate (context -> MisoString) where + translate ref = either (traceErrorId . toMisoString @String) id . translate ref + +instance + (Fluent context, context ~ context', props ~ props', model' ~ model, action ~ action') + => Translate ((MisoString -> View context' props' model' action') -> View context props model action) + where + translate ref f = translate ref $ pure @[] . f + +instance (Fluent context) => Translate (View context props model action) where + translate ref = translate ref text diff --git a/src/Miso/Fluent/Intl.hs b/src/Miso/Fluent/Intl.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Fluent/Intl.hs @@ -0,0 +1,202 @@ +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; |] diff --git a/src/Miso/Fluent/Parser.hs b/src/Miso/Fluent/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Fluent/Parser.hs @@ -0,0 +1,10 @@ +module Miso.Fluent.Parser (parse, Fluent.resource) where + +import Data.Text (Text) +import Language.Fluent.Parser (Parser) +import Language.Fluent.Parser qualified as Fluent +import Language.Fluent.Parser qualified as Parser +import Miso.Prelude + +parse :: Parser a -> MisoString -> Either String a +parse = (. fromMisoString @Text) . Parser.parse diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE CPP #-} + +module Main (main) where + +import Data.Either (isLeft) +import Data.Time (UTCTime (..), fromGregorian, secondsToDiffTime) +import Miso.Fluent +import Miso.Prelude +import Test.Hspec + ( Expectation + , HasCallStack + , Spec + , describe + , hspec + , it + , shouldBe + , shouldSatisfy + ) + +#ifdef WASM +foreign export javascript "hs_start" main :: IO () +#endif + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Locale" do + describe "from a tag" do + it "known" do + fromCode "en-GB" `shouldBe` Just (Locale "en-GB") + fromCode "ja" `shouldBe` Just (Locale "ja") + it "mixed case" $ fromCode "EN-gb" `shouldBe` Just (Locale "en-GB") + it "unknown" $ fromCode "banana" `shouldBe` (Nothing :: Maybe Locale) + it "no tag at all" $ fromCode "en_GB" `shouldBe` (Nothing :: Maybe Locale) + it "display language" $ displayLanguage ja deCH `shouldBe` Just "Japanisch" + it "local display language" $ localDisplayLanguage ja `shouldBe` Just "日本語" + + describe "Number" do + describe "grouping" do + it "grouped digits" + $ translate "value" ("arg", NumberValue 1234567 numberOptions) enGB resource + `shouldBe` Right "1,234,567" + it "no grouping" + $ translate "value" ("arg", NumberValue 1234567 numberOptions{useGrouping = False}) enGB resource + `shouldBe` Right "1234567" + describe "digits" do + it "at least three integer digits" + $ translate "value" ("arg", NumberValue 5 numberOptions{minimumIntegerDigits = 3}) enGB resource + `shouldBe` Right "005" + it "no fraction digits" + $ translate + "value" + ("arg", NumberValue 1.5 numberOptions{maximumFractionDigits = Just 0}) + enGB + resource + `shouldBe` Right "2" + it "two significant digits" + $ translate + "value" + ("arg", NumberValue 1234 numberOptions{maximumSignificantDigits = Just 2}) + enGB + resource + `shouldBe` Right "1,200" + it "at least four significant digits" + $ translate + "value" + ("arg", NumberValue 1.5 numberOptions{minimumSignificantDigits = Just 4}) + enGB + resource + `shouldBe` Right "1.500" + describe "style" do + it "a percentage" + $ translate "value" ("arg", NumberValue 0.25 numberOptions{style = Percent}) enGB resource + `shouldBe` Right "25%" + it "an amount of money" + $ translate "value" ("arg", NumberValue 12.5 numberOptions{style = Currency "EUR"}) enGB resource + `shouldBe` Right "€12.50" + it "an amount of a unit" + $ translate + "value" + ("arg", NumberValue 5 numberOptions{style = Unit "kilometre-per-hour"}) + enGB + resource + `shouldBe` Right "5 km/h" + it "an unknown unit" + $ shouldFail + $ translate "value" ("arg", NumberValue 5 numberOptions{style = Unit "banana"}) enGB resource + describe "currency" do + it "a code beside the amount" + $ translate + "value" + ("arg", NumberValue 12.5 numberOptions{style = Currency "EUR", currencyDisplay = Code}) + enGB + resource + `shouldBe` Right "EUR\160\&12.50" + it "a name beside the amount" + $ translate + "value" + ("arg", NumberValue 12.5 numberOptions{style = Currency "EUR", currencyDisplay = Name}) + enGB + resource + `shouldBe` Right "12.50 euros" + describe "unit" do + it "narrow and long names" do + translate + "value" + ("arg", NumberValue 5 numberOptions{style = Unit "litre", unitDisplay = Narrow}) + enGB + resource + `shouldBe` Right "5l" + translate + "value" + ("arg", NumberValue 5 numberOptions{style = Unit "litre", unitDisplay = Long}) + enGB + resource + `shouldBe` Right "5 litres" + it "the locale's own name" + $ translate + "value" + ("arg", NumberValue 5 numberOptions{style = Unit "litre", unitDisplay = Long}) + deCH + resource + `shouldBe` Right "5 Liter" + it "the locale's own format" + $ translate + "value" + ("arg", NumberValue 1234.5 numberOptions{minimumFractionDigits = 1}) + deCH + resource + `shouldBe` Right "1'234.5" + + describe "Plural" do + it "en-GB" do + translate "counted" ("arg", NumberValue 1 numberOptions) enGB resource + `shouldBe` Right "one" + translate "counted" ("arg", NumberValue 2 numberOptions) enGB resource + `shouldBe` Right "other" + it "ja" do + translate "counted" ("arg", NumberValue 1 numberOptions) ja resource + `shouldBe` Right "other" + translate "counted" ("arg", NumberValue 2 numberOptions) ja resource + `shouldBe` Right "other" + translate "counted" ("arg", NumberValue 5 numberOptions) ja resource + `shouldBe` Right "other" + it "ordinals" do + translate "counted" ("arg", NumberValue 1 ordinal) enGB resource + `shouldBe` Right "one" + translate "counted" ("arg", NumberValue 2 ordinal) enGB resource + `shouldBe` Right "two" + translate "counted" ("arg", NumberValue 3 ordinal) enGB resource + `shouldBe` Right "few" + translate "counted" ("arg", NumberValue 4 ordinal) enGB resource + `shouldBe` Right "other" + + describe "Time" do + it "a date of numbers" + $ translate "value" ("arg", TimeValue afternoon timeOptions) enGB resource + `shouldBe` Right "10/08/2026" + it "the locale's own order" + $ translate "value" ("arg", TimeValue afternoon timeOptions) deCH resource + `shouldBe` Right "10.8.2026" + describe "month" do + it "a long name" + $ translate + "value" + ("arg", TimeValue afternoon dated{month = Just (Right Long)}) + enGB + resource + `shouldBe` Right "10 August 2026" + it "a long name on its own" + $ translate + "value" + ("arg", TimeValue afternoon timeOptions{month = Just (Right Long)}) + enGB + resource + `shouldBe` Right "August" + it "short and narrow names" do + translate "value" ("arg", TimeValue afternoon dated{month = Just (Right Short)}) enGB resource + `shouldBe` Right "10 Aug 2026" + translate + "value" + ("arg", TimeValue afternoon timeOptions{month = Just (Right Narrow)}) + enGB + resource + `shouldBe` Right "A" + it "weekday names" do + translate "value" ("arg", TimeValue afternoon timeOptions{weekday = Just Long}) enGB resource + `shouldBe` Right "Monday" + translate "value" ("arg", TimeValue afternoon timeOptions{weekday = Just Short}) enGB resource + `shouldBe` Right "Mon" + translate "value" ("arg", TimeValue afternoon timeOptions{weekday = Just Narrow}) enGB resource + `shouldBe` Right "M" + it "a two-digit year and day" do + translate "value" ("arg", TimeValue afternoon timeOptions{year = Just TwoDigit}) enGB resource + `shouldBe` Right "26" + translate "value" ("arg", TimeValue afternoon timeOptions{day = Just TwoDigit}) enGB resource + `shouldBe` Right "10" + it "an era" + $ translate + "value" + ("arg", TimeValue afternoon timeOptions{era = Just Short, year = Just Numeric}) + enGB + resource + `shouldBe` Right "2026 AD" + describe "clock" do + it "an hour and a minute" + $ translate "value" ("arg", TimeValue afternoon clock{hour12 = Just False}) enGB resource + `shouldBe` Right "12:34" + it "seconds" + $ translate + "value" + ("arg", TimeValue afternoon clock{second = Just TwoDigit, hour12 = Just False}) + enGB + resource + `shouldBe` Right "12:34:56" + it "the locale's own clock" + $ translate "value" ("arg", TimeValue afternoon clock) enGB resource + `shouldBe` Right "12:34" + it "a twelve-hour clock" + $ translate "value" ("arg", TimeValue afternoon clock{hour12 = Just True}) enGB resource + `shouldBe` Right "12:34 pm" + describe "time zone" do + it "short and long names" do + translate + "value" + ("arg", TimeValue afternoon clock{timeZoneName = Just Short, hour12 = Just False}) + enGB + resource + `shouldBe` Right "12:34 UTC" + translate + "value" + ("arg", TimeValue afternoon clock{timeZoneName = Just Long, hour12 = Just False}) + enGB + resource + `shouldBe` Right "12:34 Coordinated Universal Time" + it "another zone" + $ translate "value" ("arg", TimeValue afternoon berlin) enGB resource + `shouldBe` Right "14:34" + it "another zone in winter" + $ translate "value" ("arg", TimeValue midwinter berlin) enGB resource + `shouldBe` Right "13:34" + + describe "Translations" do + it "MisoString" + $ translate "hello" (bundle (pure enGB) $ pure resource) + `shouldBe` ("Hello" :: MisoString) + it "View" $ (translate "hello" :: View (Bundle Locale) () () ()) `seq` pure @IO () + +shouldFail :: (HasCallStack) => Either String MisoString -> Expectation +shouldFail actual = actual `shouldSatisfy` isLeft + +resource :: Resource +resource = + [fluent| + hello = Hello + value = { $arg } + counted = { $arg -> + [one] one + [two] two + [few] few + [many] many + *[other] other + } + |] + +instance (r ~ Either String MisoString) => Translate (Locale -> Resource -> r) where + translate reference locale = translate reference . bundle (pure locale) . pure + +enGB, deCH, ja :: Locale +enGB = Locale "en-GB" +deCH = Locale "de-CH" +ja = Locale "ja" + +ordinal :: NumberOptions +ordinal = numberOptions{form = Ordinal} + +dated :: TimeOptions +dated = timeOptions{day = Just Numeric, year = Just Numeric} + +clock :: TimeOptions +clock = timeOptions{hour = Just Numeric, minute = Just TwoDigit} + +berlin :: TimeOptions +berlin = clock{timeZone = "Europe/Berlin", hour12 = Just False} + +afternoon :: UTCTime +afternoon = UTCTime (fromGregorian 2026 8 10) . secondsToDiffTime $ 12 * 3600 + 34 * 60 + 56 + +midwinter :: UTCTime +midwinter = UTCTime (fromGregorian 2026 1 10) . secondsToDiffTime $ 12 * 3600 + 34 * 60 + 56