Bundle.hs

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

module Language.Fluent.Bundle where

import Control.Applicative ((<|>))
import Control.Monad (guard, when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict (StateT)
import Control.Monad.Trans.State.Strict qualified as StateT
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
    , namedArgument
    , termArguments
    , variantKey
    )
import Language.Fluent.Pattern qualified as Pattern
import Language.Fluent.Value (Value)
import Language.Fluent.Value qualified as Value
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 Value
              -> 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.
    }

-- | A change to a 'Bundle'.
data Override
    = -- | Whether to use isolation marks around placeables.
      UseIsolating Bool
    | -- | Add a function, shadowing the builtin of the same name.
      WithFunction Identifier ([Pattern] -> HashMap Identifier Value -> Either String Pattern)

-- | Apply an 'Override' to a 'Bundle'.
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}

-- | The codes of the locales of a bundle.
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

-- | A bundle of 'Resource's for the given 'Locale's, with the default configuration.
bundle :: NonEmpty locale -> [Resource] -> Bundle locale
bundle locales resources = Bundle{locales, resources, functions = mempty, useIsolating = True}

-- | The first message of a 'Bundle' with the identifier.
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

-- | The first term of a 'Bundle' with the identifier.
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

-- | Resolve all the selections and interpolations of an AST 'AST.Pattern' to a simple 'Pattern'.
pattern
    :: (Locale locale)
    => Bundle locale
    -> HashMap Identifier Value
    -> AST.Pattern
    -> Either String Pattern
pattern bundle@Bundle{locales = locale :| _, ..} = (flip StateT.evalStateT 0 .) . resolve mempty
  where
    resolve
        :: HashSet Identifier
        -> HashMap Identifier Value
        -> AST.Pattern
        -> StateT Int (Either String) Pattern
    resolve followed arguments (AST.Pattern elements) =
        sconcat <$> sequence (NonEmpty.zipWith element (True :| repeat False) elements)
      where
        element :: Bool -> AST.PatternElement -> StateT Int (Either String) Pattern
        element _ (AST.InlineText t) = pure $ Pattern.fromValue t
        element _ (AST.BlockText t) = pure $ Pattern.fromValue t
        element first (AST.Placeable placeable) = do
            expanded <- StateT.get
            when (expanded >= 100) . lift $ Left "Too many placeables expanded"
            StateT.put $ expanded + 1
            beginsLine . isolated
                <$> expression followed arguments (AST.placeableExpression placeable)
          where
            beginsLine
                | AST.BlockPlaceable{} <- placeable, not first = ("\n" <>)
                | otherwise = id

        isolated
            | length elements > 1, useIsolating = Pattern . pure . Isolated
            | otherwise = id

    expression
        :: HashSet Identifier
        -> HashMap Identifier Value
        -> AST.Expression
        -> StateT Int (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 selector of
            AST.VariableReference name | not $ name `HashMap.member` arguments -> pure Nothing
            _ -> lift . matching variants =<< inlineExpression followed arguments selector
        AST.Variant{value = picked'} <-
            lift . maybeToEither "Select expression has no default variant" $
                picked <|> List.find AST.isDefault variants
        resolve followed arguments picked'

    matching variants (Pattern (Value selected :| [])) =
        Right $
            List.find (Value.matchesExact selected . variantKey) variants
                <|> List.find (Value.matchesCategory locale selected . variantKey) variants
    matching _ _ = Left "Selector is not a number or identifier"

    inlineExpression
        :: HashSet Identifier
        -> HashMap Identifier Value
        -> AST.InlineExpression
        -> StateT Int (Either String) Pattern
    inlineExpression _ _ (AST.StringLiteralExpression s) = pure . Pattern.fromValue $ s.value
    inlineExpression _ _ (AST.NumberLiteralExpression n) =
        pure . Pattern.fromValue . uncurry Value.Number $ Number.fromLiteral n
    inlineExpression followed arguments (AST.PlaceableExpression expr) =
        expression followed arguments expr
    inlineExpression _ arguments (AST.VariableReference id) =
        lift
            . fmap 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 <-
            lift . 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
        lift . f positional' . HashMap.fromList $ namedArgument <$> named
    inlineExpression followed arguments (AST.MessageReference id accessor) = do
        found <-
            lift . maybeToEither ("Message not found: " <> Text.unpack (coerce id)) $
                message id bundle
        found' <- lift 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 <- lift . maybeToEither ("Term not found: " <> show id) $ term id bundle
        found' <-
            lift $
                maybe
                    (Right found.value)
                    (\(AST.AttributeAccessor it) -> attributeOf (withDash id) it found.attributes)
                    accessor
        arguments' <- lift $ 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 Value
        -> Identifier
        -> AST.Pattern
        -> StateT Int (Either String) Pattern
    follow followed arguments name found
        | name `HashSet.member` followed = lift . Left $ "Cyclic reference: " <> show name
        | otherwise = resolve (HashSet.insert name followed) arguments found