Translate.hs

{-# OPTIONS_GHC -Wno-name-shadowing #-}

module Language.Fluent.Translate where

import Control.Applicative (optional)
import Data.Bifunctor (second)
import Data.Either.Extra (maybeToEither)
import Data.Foldable qualified as Foldable
import Data.Functor ((<&>))
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.String (IsString (..))
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Traversable (for)
import Language.Fluent.AST (AttributeAccessor (..), Identifier)
import Language.Fluent.AST qualified as AST
import Language.Fluent.Bundle (Bundle (..))
import Language.Fluent.Bundle qualified as Bundle
import Language.Fluent.Locale (Locale)
import Language.Fluent.Parser qualified as Parser
import Language.Fluent.Pattern qualified as Pattern
import Language.Fluent.Value (ToValue (..), Value)
import Prelude

-- | A target message or attribute lookup. Also carries accumulated variadic parameters.
data Reference = Reference
    { name :: Either String Identifier
    , attribute :: Maybe AttributeAccessor
    , arguments :: HashMap Text Value
    , overrides :: [Bundle.Override]
    }

-- | Express a 'Reference' as a string literal:
--
-- - @"message_id"@ targets a top-level message.
-- - @"message_id.attribute_name"@ targets a specific attribute.
instance IsString Reference where
    fromString s =
        Reference
            { name = fst <$> parsed
            , attribute = either (const Nothing) snd parsed
            , arguments = mempty
            , overrides = []
            }
      where
        parsed =
            Parser.parseNamed
                "reference"
                ((,) <$> Parser.identifier <*> optional Parser.attributeAccessor)
                $ Text.pack s

-- | Brings together a message reference, any number of arguments, and a bundle to form a complete
-- translation.
--
-- Instances of this class address three orthogonal concerns:
--
-- - Argument collection. Messages may require arguments before they can be translated.
--   These arguments may be passed directly or resolved implicitly from context.
-- - Bundle resolution. Ultimately all translations come from a bundle.
--   This bundle may be passed directly or resolved implicitly from context.
-- - Return type. Determines a translation's output structure and its failure semantics.
--
-- === Examples:
--
-- > -- Explicit bundle with arguments, returning an Either for safe error handling.
-- > result :: Either String Text
-- > result = translate "welcome" ("name", "Alice") bundle
--
-- > -- Rendering directly to a Miso View, which provides the bundle through the Context.
-- > view :: View Context props model action
-- > view = translate "title"
class Translate r where translate :: Reference -> r

instance (Locale locale) => Translate (Bundle locale -> Either String Text) where
    translate Reference{..} (flip (foldr Bundle.override) overrides -> bundle) = do
        name <- name
        message <- maybeToEither ("Message not found: " <> show name) $ Bundle.message name bundle
        pat <- case attribute of
            Nothing ->
                maybeToEither ("Message has no value: " <> show name) message.value
            Just (AttributeAccessor attribute) ->
                maybeToEither ("Attribute not found: " <> show attribute) $
                    Pattern.attribute attribute message.attributes
        arguments <-
            HashMap.fromList <$> for (HashMap.toList arguments) \(k, v) ->
                Parser.parseIdentifier k <&> (,v)
        Pattern.format bundle.locales =<< Bundle.pattern bundle arguments pat

instance (k ~ Text, ToValue v, Translate r) => Translate ((k, v) -> r) where
    translate reference (k, toValue -> v) =
        translate reference{arguments = HashMap.insert k v reference.arguments}

instance (Foldable f, k ~ Text, ToValue v, Translate r) => Translate (f (k, v) -> r) where
    translate reference args =
        translate reference{arguments = HashMap.union asked reference.arguments}
      where
        asked = HashMap.fromList . fmap (second toValue) . Foldable.toList $ args

instance (Translate r) => Translate (Bundle.Override -> r) where
    translate reference override = translate reference{overrides = override : reference.overrides}