Bundle.hs

{- HLINT ignore "Use zipWithM" -}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

module Language.Fluent.Bundle where

import Control.Applicative ((<|>))
import Control.Monad (guard)
import Data.Coerce (coerce)
import Data.Either (partitionEithers)
import Data.Either.Extra (maybeToEither)
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet (HashSet)
import Data.HashSet qualified as HashSet
import Data.Kind (Type)
import Data.List qualified as List
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Maybe (listToMaybe)
import Data.Semigroup (sconcat)
import Data.Text (Text)
import Data.Text qualified as Text
import Language.Fluent.AST (Identifier (Identifier), Resource (Resource))
import Language.Fluent.AST qualified as AST
import Language.Fluent.Function (builtins)
import Language.Fluent.Locale (Locale)
import Language.Fluent.Locale qualified as Locale
import Language.Fluent.Number qualified as Number
import Language.Fluent.Pattern
    ( Pattern (..)
    , PatternElement (..)
    , attribute
    , interpolates
    , matchesCategory
    , matchesExact
    , namedArgument
    , termArguments
    , variantKey
    )
import Language.Fluent.Pattern qualified as Pattern
import Language.Fluent.Value (SomeValue (..))
import Prelude

-- | A collection of Fluent resources and the configuration needed to
-- resolve and format messages for a locale.
data Bundle (locale :: Type) = Bundle
    { locales :: NonEmpty locale
    -- ^ The locale of the messages, followed by the fallback locales for number and date formatting.
    , resources :: [Resource]
    -- ^ Message and term definitions, searched in order.
    , functions
        :: HashMap
            Identifier
            ( [Pattern]
              -> HashMap Identifier SomeValue
              -> Either String Pattern
            )
    -- ^ Functions available to messages, shadowing the builtins of the same name.
    , useIsolating :: Bool
    -- ^ Whether to use isolation marks (FSI, PDI) around interpolated values.
    }

data Override
    = UseIsolating Bool
    | WithFunction Identifier ([Pattern] -> HashMap Identifier SomeValue -> Either String Pattern)

override :: Override -> Bundle locale -> Bundle locale
override (UseIsolating useIsolating) bundle = bundle{useIsolating}
override (WithFunction name f) bundle = bundle{functions = HashMap.insert name f bundle.functions}

localeCodes :: (Locale locale) => Bundle locale -> NonEmpty Text
localeCodes Bundle{locales} = Locale.toCode <$> locales

-- | Only the names of the @functions@ are compared, since their implementations
-- cannot be compared for equality.
instance (Locale locale) => Eq (Bundle locale) where
    b1 == b2 =
        localeCodes b1 == localeCodes b2
            && b1.resources == b2.resources
            && HashMap.keysSet b1.functions == HashMap.keysSet b2.functions
            && b1.useIsolating == b2.useIsolating

instance (Locale locale) => Show (Bundle locale) where
    show bundle =
        Text.unpack $
            "Bundle{"
                <> Text.intercalate
                    ","
                    [ locales
                    , resources
                    , functions
                    , useIsolating
                    ]
                <> "}"
      where
        locales =
            "locales=" <> Text.show (NonEmpty.toList . localeCodes $ bundle)
        resources = "resources=" <> Text.show bundle.resources
        functions = "functions=" <> Text.show (HashMap.keys bundle.functions)
        useIsolating = "useIsolating=" <> Text.show bundle.useIsolating

bundle :: NonEmpty locale -> [Resource] -> Bundle locale
bundle locales resources = Bundle{locales, resources, functions = mempty, useIsolating = True}

message :: Identifier -> Bundle locale -> Maybe AST.Message
message id Bundle{resources} = listToMaybe do
    Resource{entries} <- resources
    AST.MessageEntry found <- entries
    guard $ found.id == id
    pure found

term :: Identifier -> Bundle locale -> Maybe AST.Term
term name Bundle{resources} = listToMaybe do
    Resource{entries} <- resources
    AST.TermEntry found <- entries
    guard $ found.id == name
    pure found

pattern
    :: (Locale locale)
    => Bundle locale
    -> HashMap Identifier SomeValue
    -> AST.Pattern
    -> Either String Pattern
pattern bundle@Bundle{locales = locale :| _, ..} = resolve mempty
  where
    resolve
        :: HashSet Identifier
        -> HashMap Identifier SomeValue
        -> AST.Pattern
        -> Either String Pattern
    resolve followed arguments (AST.Pattern elements) =
        sconcat <$> sequence (NonEmpty.zipWith element (True :| repeat False) elements)
      where
        element :: Bool -> AST.PatternElement -> Either String Pattern
        element _ (AST.InlineText t) = Right $ Pattern.fromValue t
        element _ (AST.BlockText t) = Right $ Pattern.fromValue t
        element first (AST.Placeable placeable) =
            beginsLine . isolated <$> expression followed arguments expr
          where
            expr = AST.placeableExpression placeable
            isolated
                | length elements > 1
                , useIsolating
                , interpolates expr =
                    Pattern . pure . Isolated
                | otherwise = id
            beginsLine
                | AST.BlockPlaceable{} <- placeable, not first = ("\n" <>)
                | otherwise = id

    expression
        :: HashSet Identifier
        -> HashMap Identifier SomeValue
        -> AST.Expression
        -> Either String Pattern
    expression followed arguments (AST.Inline inline) =
        inlineExpression followed arguments inline
    expression followed arguments (AST.Select (AST.SelectExpression selector variants')) = do
        let AST.VariantList variants = variants'
        picked <- case inlineExpression followed arguments selector of
            Left{} -> Right Nothing
            Right (Pattern (Value selected :| [])) ->
                Right $
                    List.find (matchesExact selected . variantKey) variants
                        <|> List.find (matchesCategory locale selected . variantKey) variants
            Right{} -> Left "Selector is not a number or identifier"
        AST.Variant{value = picked'} <-
            maybeToEither "Select expression has no default variant" $
                picked <|> List.find AST.isDefault variants
        resolve followed arguments picked'

    inlineExpression
        :: HashSet Identifier
        -> HashMap Identifier SomeValue
        -> AST.InlineExpression
        -> Either String Pattern
    inlineExpression _ _ (AST.StringLiteralExpression s) = Right . Pattern.fromValue $ s.value
    inlineExpression _ _ (AST.NumberLiteralExpression n) =
        Right . Pattern.fromValue . uncurry NumberValue $ Number.fromLiteral n
    inlineExpression followed arguments (AST.PlaceableExpression expr) =
        expression followed arguments expr
    inlineExpression _ arguments (AST.VariableReference id) =
        Pattern.fromValue
            <$> maybeToEither
                ("Variable not found: " <> show id)
                (HashMap.lookup id arguments)
    inlineExpression followed arguments (AST.FunctionReference id called) = do
        let AST.CallArguments args = called
        f <-
            maybeToEither ("Function not found: " <> show id) $
                HashMap.lookup id bundle.functions <|> HashMap.lookup id builtins
        let (named, positional) = partitionEithers args
        positional' <- traverse (inlineExpression followed arguments) positional
        f positional' . HashMap.fromList $ namedArgument <$> named
    inlineExpression followed arguments (AST.MessageReference id accessor) = do
        found <-
            maybeToEither ("Message not found: " <> Text.unpack (coerce id)) $ message id bundle
        found' <- case accessor of
            Nothing -> maybeToEither ("Message has no value: " <> show id) found.value
            Just (AST.AttributeAccessor it) -> attributeOf id it found.attributes
        follow followed arguments (reference (coerce id) accessor) found'
    inlineExpression followed _ (AST.TermReference id accessor args) = do
        found <- maybeToEither ("Term not found: " <> show id) $ term id bundle
        found <-
            maybe
                (Right found.value)
                (\(AST.AttributeAccessor it) -> attributeOf (withDash id) it found.attributes)
                accessor
        arguments' <- termArguments args
        follow followed arguments' (reference (withDash id) accessor) found

    attributeOf
        :: Identifier
        -> Identifier
        -> [AST.Attribute]
        -> Either String AST.Pattern
    attributeOf owner name attributes =
        maybeToEither ("Attribute not found: " <> show (owner, name)) $
            attribute name attributes

    withDash :: Identifier -> Identifier
    withDash (Identifier i) = Identifier $ "-" <> i

    reference :: Identifier -> Maybe AST.AttributeAccessor -> Identifier
    reference (Identifier name) (Just (AST.AttributeAccessor (Identifier it))) = Identifier $ name <> "." <> it
    reference name _ = name

    follow
        :: HashSet Identifier
        -> HashMap Identifier SomeValue
        -> Identifier
        -> AST.Pattern
        -> Either String Pattern
    follow followed arguments name found
        | name `HashSet.member` followed = Left $ "Cyclic reference: " <> show name
        | otherwise = resolve (HashSet.insert name followed) arguments found