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/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/fluent-effectful.cabal b/fluent-effectful.cabal new file mode 100644 --- /dev/null +++ b/fluent-effectful.cabal @@ -0,0 +1,92 @@ +cabal-version: 3.0 +name: fluent-effectful +version: 1.0.0 +category: Language +synopsis: Fluent effect for Effectful +description: + Adaptation of the @@ library for the @@ ecosystem. + +license: EUPL-1.2 +author: IDA +maintainer: IDA +homepage: https://digital-autonomy.institute +bug-reports: https://issues.digital-autonomy.institute +build-type: Simple +extra-doc-files: + CHANGELOG.md + +common common + default-language: Haskell2010 + ghc-options: + -Weverything + -Wno-unsafe + -Wno-all-missed-specialisations + -Wno-missing-export-lists + -Wno-missing-import-lists + -Wno-missing-kind-signatures + -Wno-missing-poly-kind-signatures + -Wno-missing-role-annotations + -Wno-missing-safe-haskell-mode + -Wno-name-shadowing + + default-extensions: + ApplicativeDo + BlockArguments + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + ExplicitNamespaces + FlexibleContexts + FlexibleInstances + GADTs + ImportQualifiedPost + LambdaCase + NoImplicitPrelude + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + RankNTypes + RecordWildCards + RecursiveDo + ScopedTypeVariables + TemplateHaskell + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + + build-depends: + base >=4.10 && <5, + effectful >=2.6 && <2.8, + text >=2.1 && <2.2, + +library + import: common + hs-source-dirs: src + exposed-modules: + Effectful.Fluent.Multi + Effectful.Fluent.Single + + build-depends: + fluent >=1.0 && <1.1, + unordered-containers >=0.2 && <0.3, + +test-suite test + import: common + type: exitcode-stdio-1.0 + ghc-options: -threaded + hs-source-dirs: test + main-is: Main.hs + build-tool-depends: hspec-effectful-discover:hspec-effectful-discover + build-depends: + fluent-effectful, + fluent-icu >=1.0 && <1.1, + hspec-effectful >=1.0 && <1.2, + + other-modules: + Effectful.Fluent.MultiSpec + Effectful.Fluent.SingleSpec + Util diff --git a/src/Effectful/Fluent/Multi.hs b/src/Effectful/Fluent/Multi.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Fluent/Multi.hs @@ -0,0 +1,96 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- Module : Effectful.Fluent.Multi +-- Copyright : (c) 2026 Institute for Digital Autonomy +-- License : EUPL-1.2 +-- Maintainer : IDA +-- +-- translation support for the +-- ecosystem, for applications +-- targeting multiple languages. +-- +-- This module provides the 'Fluent' effect and 'runFluent' interpreter to translate +-- messages against a single 'Bundle'. +-- +-- This library does not provide any concrete instances of 'Locale'. +-- Pair it with a locale provider such as . +-- +-- = Quickstart +-- +-- == 1. Parsing resources +-- +-- Embed Fluent resources at compile time using the 'fluent' quasi-quoter: +-- +-- > let enRes = [fluent|welcome = Welcome, { $name }|] +-- > deRes = [fluent|welcome = Willkommen, { $name }|] +-- +-- Or parse Fluent source at runtime with 'parseResource': +-- +-- > enRes <- either fail pure . parseResource =<< Text.readFile "en-GB.ftl" +-- > deRes <- either fail pure . parseResource =<< Text.readFile "de-CH.ftl" +-- +-- == 2. Building bundles +-- +-- Combine 'Resource's and 'Locale's into 'Bundle's using 'bundle': +-- +-- > let enGB, deCH :: LocaleName +-- > enGB = "en-GB" +-- > deCH = "de-CH" +-- > english = bundle @LocaleName (pure enGB) [enRes] +-- > swiss = bundle @LocaleName (pure deCH) [deRes] +-- +-- == 3. Running the effect +-- +-- Pass the collection of 'Bundle's to 'runFluent'. Translations select the bundle matching +-- the target locale supplied to 'translate': +-- +-- > main :: IO () +-- > main = runEff . runFluent [english, swiss] $ do +-- > translate "welcome" ("name", value @Text "Ann") enGB >>= liftIO . print +-- > -- Right "Welcome, Ann" +-- > translate "welcome" ("name", value @Text "Ann") deCH >>= liftIO . print +-- > -- Right "Willkommen, Ann" +module Effectful.Fluent.Multi + ( -- * Effect + Fluent + , runFluent + + -- * Re-exports + , module Language.Fluent + ) +where + +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text (Text) +import Data.Text qualified as Text +import Effectful +import Effectful.Dispatch.Static (SideEffects (..), StaticRep, evalStaticRep, getStaticRep) +import Language.Fluent +import Language.Fluent.Locale qualified as Locale +import Prelude + +-- | Translates from a t'Bundle' per locale, chosen by the locale passed to 'translate'. +data Fluent :: Effect + +type instance DispatchOf Fluent = 'Static 'NoSideEffects + +data instance StaticRep Fluent where + Fluent :: (Locale locale) => HashMap Text (Bundle locale) -> StaticRep Fluent + +-- | Translate with the given t'Bundle's in the effectful computation. +-- Each bundle is known by the first of its locales. +runFluent :: (Locale locale) => [Bundle locale] -> Eff (Fluent ': es) a -> Eff es a +runFluent = + evalStaticRep + . Fluent + . foldr (\bundle -> HashMap.insert (Locale.toCode $ NonEmpty.head bundle.locales) bundle) mempty + +instance (Locale locale, Fluent :> es, r ~ Either String Text) => Translate (locale -> Eff es r) where + translate ref (Locale.toCode -> locale) = do + Fluent bundles <- getStaticRep + pure $ case HashMap.lookup locale bundles of + Nothing -> Left . Text.unpack $ "No bundle for locale " <> locale + Just bundle -> translate ref bundle diff --git a/src/Effectful/Fluent/Single.hs b/src/Effectful/Fluent/Single.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Fluent/Single.hs @@ -0,0 +1,80 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- Module : Effectful.Fluent.Single +-- Copyright : (c) 2026 Institute for Digital Autonomy +-- License : EUPL-1.2 +-- Maintainer : IDA +-- +-- translation support for the +-- ecosystem, for applications +-- targeting a single language. +-- +-- This module provides the 'Fluent' effect and 'runFluent' interpreter to translate +-- messages against a collection of 'Bundle's selected by locale code. +-- +-- This library does not provide any concrete instances of 'Locale'. +-- Pair it with a locale provider such as . +-- +-- = 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 with 'parseResource': +-- +-- > resource <- either fail pure . parseResource =<< Text.readFile "en-GB.ftl" +-- +-- == 2. Building bundles +-- +-- Combine 'Resource's and 'Locale's into a 'Bundle' using 'bundle': +-- +-- > let english = bundle @LocaleName (pure "en-GB") [resource] +-- +-- == 3. Running the effect +-- +-- Pass the 'Bundle' to 'runFluent' and translate messages with 'translate': +-- +-- > main :: IO () +-- > main = runEff . runFluent english $ do +-- > translate "greeting" >>= liftIO . print +-- > -- Right "Hello!" +-- > translate "welcome" ("name", value @Text "Ann") >>= liftIO . print +-- > -- Right "Welcome, Ann" +module Effectful.Fluent.Single + ( -- * Effect + Fluent + , runFluent + + -- * Re-exports + , module Language.Fluent + ) +where + +import Data.Text (Text) +import Effectful +import Effectful.Dispatch.Static (SideEffects (..), StaticRep, evalStaticRep, getStaticRep) +import Language.Fluent +import Prelude + +-- | Translates from a single t'Bundle'. +data Fluent :: Effect + +type instance DispatchOf Fluent = 'Static 'NoSideEffects + +data instance StaticRep Fluent where + Fluent :: (Locale locale) => Bundle locale -> StaticRep Fluent + +-- | Translate with the given t'Bundle' in the effectful computation. +runFluent :: (Locale locale) => Bundle locale -> Eff (Fluent ': es) a -> Eff es a +runFluent = evalStaticRep . Fluent + +instance (Fluent :> es, r ~ Either String Text) => Translate (Eff es r) where + translate ref = (\(Fluent bundle) -> translate ref bundle) <$> getStaticRep @Fluent diff --git a/test/Effectful/Fluent/MultiSpec.hs b/test/Effectful/Fluent/MultiSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Fluent/MultiSpec.hs @@ -0,0 +1,41 @@ +module Effectful.Fluent.MultiSpec (spec) where + +import Data.Text (Text) +import Effectful +import Effectful.Fluent.Multi +import Effectful.Hspec +import Language.Fluent.ICU +import Util +import Prelude + +spec :: (Hspec :> es) => Eff es () +spec = do + it "reads a message in the language it is asked for" $ runFluent [english, swiss] do + translate "greeting" enGB `shouldReturn` Right "Hello!" + translate "greeting" deCH `shouldReturn` Right "Grüezi!" + + it "reads the arguments a message of that language asks for" $ runFluent [english, swiss] do + translate "welcome" ("name", "Ann" :: Text) enGB `shouldReturn` Right "Welcome, \8296Ann\8297" + translate "welcome" ("name", "Ann" :: Text) deCH `shouldReturn` Right "Willkommen, \8296Ann\8297" + + it "reads a message of the one language that holds it" $ runFluent [english, swiss] do + translate "biscuit" enGB `shouldReturn` Right "Biscuit" + translate "biscuit" deCH `shouldReturn` Left "Message not found: \"biscuit\"" + + it "holds no bundle of a language it was given none of" $ runFluent [english] do + translate "greeting" deCH `shouldReturn` Left "No bundle for locale de-CH" + + it "holds no bundle at all where it was given none" $ runFluent @LocaleName [] do + translate "greeting" enGB `shouldReturn` Left "No bundle for locale en-GB" + + it "reads the first bundle of a language it was given two of" $ + runFluent [english, shouting] do + translate "greeting" enGB `shouldReturn` Right "Hello!" + + it "knows a bundle by that name and by no shorter or longer one" $ runFluent [english] do + translate "greeting" en `shouldReturn` Left "No bundle for locale en" + translate "greeting" enGBOxendict `shouldReturn` Left "No bundle for locale en-GB-oxendict" + + it "reads what a caller asks of the bundle it reads from" $ runFluent [english] do + translate "shouted" (UseIsolating False) enGB `shouldReturn` Right "a Hello! b" + translate "shouted" enGB `shouldReturn` Right "a \8296Hello!\8297 b" diff --git a/test/Effectful/Fluent/SingleSpec.hs b/test/Effectful/Fluent/SingleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Fluent/SingleSpec.hs @@ -0,0 +1,17 @@ +module Effectful.Fluent.SingleSpec (spec) where + +import Data.Text (Text) +import Effectful +import Effectful.Fluent.Single +import Effectful.Hspec +import Util +import Prelude + +spec :: (Hspec :> es) => Eff es () +spec = runFluent english do + it "reads from its one bundle without being told a locale" do + translate "greeting" `shouldReturn` Right "Hello!" + translate "welcome" ("name", "Ann" :: Text) `shouldReturn` Right "Welcome, \8296Ann\8297" + + it "says why a message is missing" do + translate "missing" `shouldReturn` Left "Message not found: \"missing\"" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-effectful-discover #-} diff --git a/test/Util.hs b/test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Util.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Util where + +import Language.Fluent.ICU +import Prelude + +enGB, deCH, de, en, enGBOxendict :: LocaleName +enGB = "en-GB" +deCH = "de-CH" +de = "de" +en = "en" +enGBOxendict = "en-GB-oxendict" + +english, swiss, shouting :: Bundle LocaleName +english = + bundle (pure enGB) . pure $ + [fluent| + greeting = Hello! + welcome = Welcome, { $name } + biscuit = Biscuit + shouted = a { greeting } b + |] +swiss = + bundle (pure deCH) . pure $ + [fluent| + greeting = Grüezi! + welcome = Willkommen, { $name } + |] +shouting = + bundle (pure enGB) . pure $ + [fluent| + greeting = HELLO! + |]