{-# 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 t :: 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 e :: 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 n :: 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
  [ ("af", Text -> Maybe Text
forall a. a -> Maybe a
Just "ZA"),
    ("ar", Maybe Text
forall a. Maybe a
Nothing),
    ("bg", Text -> Maybe Text
forall a. a -> Maybe a
Just "BG"),
    ("ca", Text -> Maybe Text
forall a. a -> Maybe a
Just "AD"),
    ("cs", Text -> Maybe Text
forall a. a -> Maybe a
Just "CZ"),
    ("cy", Text -> Maybe Text
forall a. a -> Maybe a
Just "GB"),
    ("da", Text -> Maybe Text
forall a. a -> Maybe a
Just "DK"),
    ("de", Text -> Maybe Text
forall a. a -> Maybe a
Just "DE"),
    ("el", Text -> Maybe Text
forall a. a -> Maybe a
Just "GR"),
    ("en", Text -> Maybe Text
forall a. a -> Maybe a
Just "US"),
    ("es", Text -> Maybe Text
forall a. a -> Maybe a
Just "ES"),
    ("et", Text -> Maybe Text
forall a. a -> Maybe a
Just "EE"),
    ("eu", Maybe Text
forall a. Maybe a
Nothing),
    ("fa", Text -> Maybe Text
forall a. a -> Maybe a
Just "IR"),
    ("fi", Text -> Maybe Text
forall a. a -> Maybe a
Just "FI"),
    ("fr", Text -> Maybe Text
forall a. a -> Maybe a
Just "FR"),
    ("he", Text -> Maybe Text
forall a. a -> Maybe a
Just "IL"),
    ("hr", Text -> Maybe Text
forall a. a -> Maybe a
Just "HR"),
    ("hu", Text -> Maybe Text
forall a. a -> Maybe a
Just "HU"),
    ("id", Text -> Maybe Text
forall a. a -> Maybe a
Just "ID"),
    ("is", Text -> Maybe Text
forall a. a -> Maybe a
Just "IS"),
    ("it", Text -> Maybe Text
forall a. a -> Maybe a
Just "IT"),
    ("ja", Text -> Maybe Text
forall a. a -> Maybe a
Just "JP"),
    ("km", Text -> Maybe Text
forall a. a -> Maybe a
Just "KH"),
    ("ko", Text -> Maybe Text
forall a. a -> Maybe a
Just "KR"),
    ("la", Maybe Text
forall a. Maybe a
Nothing),
    ("lt", Text -> Maybe Text
forall a. a -> Maybe a
Just "LT"),
    ("lv", Text -> Maybe Text
forall a. a -> Maybe a
Just "LV"),
    ("mn", Text -> Maybe Text
forall a. a -> Maybe a
Just "MN"),
    ("nb", Text -> Maybe Text
forall a. a -> Maybe a
Just "NO"),
    ("nl", Text -> Maybe Text
forall a. a -> Maybe a
Just "NL"),
    ("nn", Text -> Maybe Text
forall a. a -> Maybe a
Just "NO"),
    ("pl", Text -> Maybe Text
forall a. a -> Maybe a
Just "PL"),
    ("pt", Text -> Maybe Text
forall a. a -> Maybe a
Just "PT"),
    ("ro", Text -> Maybe Text
forall a. a -> Maybe a
Just "RO"),
    ("ru", Text -> Maybe Text
forall a. a -> Maybe a
Just "RU"),
    ("sk", Text -> Maybe Text
forall a. a -> Maybe a
Just "SK"),
    ("sl", Text -> Maybe Text
forall a. a -> Maybe a
Just "SI"),
    ("sr", Text -> Maybe Text
forall a. a -> Maybe a
Just "RS"),
    ("sv", Text -> Maybe Text
forall a. a -> Maybe a
Just "SE"),
    ("th", Text -> Maybe Text
forall a. a -> Maybe a
Just "TH"),
    ("tr", Text -> Maybe Text
forall a. a -> Maybe a
Just "TR"),
    ("uk", Text -> Maybe Text
forall a. a -> Maybe a
Just "UA"),
    ("vi", Text -> Maybe Text
forall a. a -> Maybe a
Just "VN"),
    ("zh", Text -> Maybe Text
forall a. a -> Maybe a
Just "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
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
    Nothing       -> Maybe Lang
forall a. Maybe a
Nothing
    Just mbregion :: 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 (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 (fp :: String
fp, bs :: ByteString
bs) m :: Map Text (Either CiteprocError Locale)
m
     | String -> String
takeExtension String
fp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ".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
lang =
  let toCode :: Lang -> Text
toCode l :: 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
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 (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
               (\l :: 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 loc :: Either CiteprocError Locale
loc -> Either CiteprocError Locale
loc
        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
locale termname :: 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 ((_,t :: Text
t):_) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
     _              -> Maybe Text
forall a. Maybe a
Nothing

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