    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE OverloadedStrings #-}
    module Citeproc.Locale
      ( parseLocale,
        getLocale,
        getPrimaryDialect,
        lookupQuotes
      )
    where
    import Citeproc.Types
    import Citeproc.Element (runElementParser, pLocale)
    import Citeproc.Data (localeFiles)
    import qualified Data.Map as M
    import Data.Maybe (fromMaybe)
    import Data.Text (Text)
    import qualified Text.XML as X
    import System.FilePath (takeExtension, dropExtension)
    import qualified Data.Text as T
    import Data.Default (def)
    import qualified Data.Text.Lazy as TL
    import Data.Text.Encoding (decodeUtf8)
    import Control.Applicative ((<|>))

    -- | Parse a CSL locale definition (XML).  For information about
    -- the format, see
    -- <https://docs.citationstyles.org/en/stable/translating-locale-files.html>.
    parseLocale :: Text -> Either CiteprocError Locale
    parseLocale :: Text -> Either CiteprocError Locale
    parseLocale Text
    t =
      case ParseSettings -> Text -> Either SomeException Document
    X.parseText ParseSettings
    forall a. Default a => a
    def (Text -> Either SomeException Document)
    -> Text -> Either SomeException Document
    forall a b. (a -> b) -> a -> b
    $ Text -> Text
    TL.fromStrict Text
    t of
           Left SomeException
    e -> CiteprocError -> Either CiteprocError Locale
    forall a b. a -> Either a b
    Left (CiteprocError -> Either CiteprocError Locale)
    -> CiteprocError -> Either CiteprocError Locale
    forall a b. (a -> b) -> a -> b
    $ Text -> CiteprocError
    CiteprocXMLError (String -> Text
    T.pack (SomeException -> String
    forall a. Show a => a -> String
    show SomeException
    e))
           Right Document
    n -> ElementParser Locale -> Either CiteprocError Locale
    forall a. ElementParser a -> Either CiteprocError a
    runElementParser (ElementParser Locale -> Either CiteprocError Locale)
    -> ElementParser Locale -> Either CiteprocError Locale
    forall a b. (a -> b) -> a -> b
    $ Element -> ElementParser Locale
    pLocale (Element -> ElementParser Locale)
    -> Element -> ElementParser Locale
    forall a b. (a -> b) -> a -> b
    $ Document -> Element
    X.documentRoot Document
    n

    primaryDialectMap :: M.Map Text (Maybe Text)
    primaryDialectMap :: Map Text (Maybe Text)
    primaryDialectMap = [(Text, Maybe Text)] -> Map Text (Maybe Text)
    forall k a. Ord k => [(k, a)] -> Map k a
    M.fromList
      [ (Text
    "af", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "ZA"),
        (Text
    "ar", Maybe Text
    forall a. Maybe a
    Nothing),
        (Text
    "bg", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "BG"),
        (Text
    "ca", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "AD"),
        (Text
    "cs", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "CZ"),
        (Text
    "cy", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "GB"),
        (Text
    "da", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "DK"),
        (Text
    "de", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "DE"),
        (Text
    "el", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "GR"),
        (Text
    "en", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "US"),
        (Text
    "es", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "ES"),
        (Text
    "et", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "EE"),
        (Text
    "eu", Maybe Text
    forall a. Maybe a
    Nothing),
        (Text
    "fa", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "IR"),
        (Text
    "fi", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "FI"),
        (Text
    "fr", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "FR"),
        (Text
    "he", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "IL"),
        (Text
    "hr", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "HR"),
        (Text
    "hu", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "HU"),
        (Text
    "id", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "ID"),
        (Text
    "is", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "IS"),
        (Text
    "it", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "IT"),
        (Text
    "ja", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "JP"),
        (Text
    "km", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "KH"),
        (Text
    "ko", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "KR"),
        (Text
    "la", Maybe Text
    forall a. Maybe a
    Nothing),
        (Text
    "lt", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "LT"),
        (Text
    "lv", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "LV"),
        (Text
    "mn", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "MN"),
        (Text
    "nb", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "NO"),
        (Text
    "nl", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "NL"),
        (Text
    "nn", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "NO"),
        (Text
    "pl", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "PL"),
        (Text
    "pt", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "PT"),
        (Text
    "ro", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "RO"),
        (Text
    "ru", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "RU"),
        (Text
    "sk", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "SK"),
        (Text
    "sl", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "SI"),
        (Text
    "sr", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "RS"),
        (Text
    "sv", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "SE"),
        (Text
    "th", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "TH"),
        (Text
    "tr", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "TR"),
        (Text
    "uk", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "UA"),
        (Text
    "vi", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "VN"),
        (Text
    "zh", Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "CN")
        ]

    -- | Retrieves the "primary dialect" corresponding to a language,
    -- e.g. "lt-LT" for "lt".
    getPrimaryDialect :: Lang -> Maybe Lang
    getPrimaryDialect :: Lang -> Maybe Lang
    getPrimaryDialect Lang
    lang =
      case Text -> Map Text (Maybe Text) -> Maybe (Maybe Text)
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup (Lang -> Text
    langLanguage Lang
    lang) Map Text (Maybe Text)
    primaryDialectMap of
        Maybe (Maybe Text)
    Nothing       -> Maybe Lang
    forall a. Maybe a
    Nothing
        Just Maybe Text
    mbregion -> Lang -> Maybe Lang
    forall a. a -> Maybe a
    Just (Lang -> Maybe Lang) -> Lang -> Maybe Lang
    forall a b. (a -> b) -> a -> b
    $ Lang
    lang{ langRegion :: Maybe Text
    langRegion = Maybe Text
    mbregion }

    locales :: M.Map Text (Either CiteprocError Locale)
    locales :: Map Text (Either CiteprocError Locale)
    locales = ((String, ByteString)
     -> Map Text (Either CiteprocError Locale)
     -> Map Text (Either CiteprocError Locale))
    -> Map Text (Either CiteprocError Locale)
    -> [(String, ByteString)]
    -> Map Text (Either CiteprocError Locale)
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (String, ByteString)
    -> Map Text (Either CiteprocError Locale)
    -> Map Text (Either CiteprocError Locale)
    go Map Text (Either CiteprocError Locale)
    forall a. Monoid a => a
    mempty [(String, ByteString)]
    localeFiles
      where
       go :: (String, ByteString)
    -> Map Text (Either CiteprocError Locale)
    -> Map Text (Either CiteprocError Locale)
    go (String
    fp, ByteString
    bs) Map Text (Either CiteprocError Locale)
    m
         | String -> String
    takeExtension String
    fp String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    ".xml"
         = let lang :: Text
    lang = String -> Text
    T.pack (String -> Text) -> String -> Text
    forall a b. (a -> b) -> a -> b
    $ String -> String
    dropExtension String
    fp
           in Text
    -> Either CiteprocError Locale
    -> Map Text (Either CiteprocError Locale)
    -> Map Text (Either CiteprocError Locale)
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    M.insert Text
    lang (Text -> Either CiteprocError Locale
    parseLocale (Text -> Either CiteprocError Locale)
    -> Text -> Either CiteprocError Locale
    forall a b. (a -> b) -> a -> b
    $ ByteString -> Text
    decodeUtf8 ByteString
    bs) Map Text (Either CiteprocError Locale)
    m
         | Bool
    otherwise = Map Text (Either CiteprocError Locale)
    m

    -- | Retrieves the locale defined for the specified language.
    -- Implements the locale fallback algorithm described in the CSL 1.0.1 spec.
    getLocale :: Lang -> Either CiteprocError Locale
    getLocale :: Lang -> Either CiteprocError Locale
    getLocale Lang
    lang =
      let toCode :: Lang -> Text
    toCode Lang
    l = Lang -> Text
    langLanguage Lang
    l Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> (Text -> Text) -> Maybe Text -> Text
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Text
    "" (Text
    "-"Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <>) (Lang -> Maybe Text
    langRegion Lang
    l)
       in case Text
    -> Map Text (Either CiteprocError Locale)
    -> Maybe (Either CiteprocError Locale)
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup (Lang -> Text
    toCode Lang
    lang) Map Text (Either CiteprocError Locale)
    locales
              Maybe (Either CiteprocError Locale)
    -> Maybe (Either CiteprocError Locale)
    -> Maybe (Either CiteprocError Locale)
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> (Lang -> Maybe Lang
    getPrimaryDialect Lang
    lang Maybe Lang
    -> (Lang -> Maybe (Either CiteprocError Locale))
    -> Maybe (Either CiteprocError Locale)
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>=
                   (\Lang
    l -> Text
    -> Map Text (Either CiteprocError Locale)
    -> Maybe (Either CiteprocError Locale)
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup (Lang -> Text
    toCode Lang
    l) Map Text (Either CiteprocError Locale)
    locales)) of
            Just Either CiteprocError Locale
    loc -> Either CiteprocError Locale
    loc
            Maybe (Either CiteprocError Locale)
    Nothing  -> CiteprocError -> Either CiteprocError Locale
    forall a b. a -> Either a b
    Left (CiteprocError -> Either CiteprocError Locale)
    -> CiteprocError -> Either CiteprocError Locale
    forall a b. (a -> b) -> a -> b
    $ Text -> CiteprocError
    CiteprocLocaleNotFound (Text -> CiteprocError) -> Text -> CiteprocError
    forall a b. (a -> b) -> a -> b
    $ Lang -> Text
    renderLang Lang
    lang

    lookupTerm :: Locale -> Text -> Maybe Text
    lookupTerm :: Locale -> Text -> Maybe Text
    lookupTerm Locale
    locale Text
    termname = do
      let terms :: Map Text [(Term, Text)]
    terms = Locale -> Map Text [(Term, Text)]
    localeTerms Locale
    locale
      case Text -> Map Text [(Term, Text)] -> Maybe [(Term, Text)]
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup Text
    termname Map Text [(Term, Text)]
    terms of
         Just ((Term
    _,Text
    t):[(Term, Text)]
    _) -> Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    t
         Maybe [(Term, Text)]
    _              -> Maybe Text
    forall a. Maybe a
    Nothing

    lookupQuotes :: Locale -> ((Text, Text), (Text, Text))
    lookupQuotes :: Locale -> ((Text, Text), (Text, Text))
    lookupQuotes Locale
    locale = ((Text
    outerOpen, Text
    outerClose), (Text
    innerOpen, Text
    innerClose))
     where
      outerOpen :: Text
    outerOpen = Text -> Maybe Text -> Text
    forall a. a -> Maybe a -> a
    fromMaybe Text
    "\x201C" (Maybe Text -> Text) -> Maybe Text -> Text
    forall a b. (a -> b) -> a -> b
    $ Locale -> Text -> Maybe Text
    lookupTerm Locale
    locale Text
    "open-quote"
      outerClose :: Text
    outerClose = Text -> Maybe Text -> Text
    forall a. a -> Maybe a -> a
    fromMaybe Text
    "\x201D" (Maybe Text -> Text) -> Maybe Text -> Text
    forall a b. (a -> b) -> a -> b
    $ Locale -> Text -> Maybe Text
    lookupTerm Locale
    locale Text
    "close-quote"
      innerOpen :: Text
    innerOpen = Text -> Maybe Text -> Text
    forall a. a -> Maybe a -> a
    fromMaybe Text
    "\x2018" (Maybe Text -> Text) -> Maybe Text -> Text
    forall a b. (a -> b) -> a -> b
    $ Locale -> Text -> Maybe Text
    lookupTerm Locale
    locale Text
    "open-inner-quote"
      innerClose :: Text
    innerClose = Text -> Maybe Text -> Text
    forall a. a -> Maybe a -> a
    fromMaybe Text
    "\x2019" (Maybe Text -> Text) -> Maybe Text -> Text
    forall a b. (a -> b) -> a -> b
    $ Locale -> Text -> Maybe Text
    lookupTerm Locale
    locale Text
    "close-inner-quote"