Locale.hs

{-# 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 t =
  case X.parseText def $ TL.fromStrict t of
       Left e -> Left $ CiteprocXMLError (T.pack (show e))
       Right n -> runElementParser $ pLocale $ X.documentRoot n

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

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


locales :: M.Map Text (Either CiteprocError Locale)
locales = foldr go mempty localeFiles
  where
   go (fp, bs) m
     | takeExtension fp == ".xml"
     = let lang = T.pack $ dropExtension fp
       in M.insert lang (parseLocale $ decodeUtf8 bs) m
     | otherwise = 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 =
  let toCode l = langLanguage l <> maybe "" ("-"<>) (langRegion l)
   in case M.lookup (toCode lang) locales
          <|> (getPrimaryDialect lang >>=
               (\l -> M.lookup (toCode l) locales)) of
        Just loc -> loc
        Nothing  -> Left $ CiteprocLocaleNotFound $ renderLang lang

lookupTerm :: Locale -> Text -> Maybe Text
lookupTerm locale termname = do
  let terms = localeTerms locale
  case M.lookup termname terms of
     Just ((_,t):_) -> Just t
     _              -> Nothing

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