{-# 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 forall a. Default a => a
def forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.fromStrict Text
t of
       Left SomeException
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> CiteprocError
CiteprocXMLError (String -> Text
T.pack (forall a. Show a => a -> String
show SomeException
e))
       Right Document
n -> forall a. ElementParser a -> Either CiteprocError a
runElementParser forall a b. (a -> b) -> a -> b
$ Element -> ElementParser Locale
pLocale 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 = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (Text
"af", forall a. a -> Maybe a
Just Text
"ZA"),
    (Text
"ar", forall a. Maybe a
Nothing),
    (Text
"bg", forall a. a -> Maybe a
Just Text
"BG"),
    (Text
"ca", forall a. a -> Maybe a
Just Text
"AD"),
    (Text
"cs", forall a. a -> Maybe a
Just Text
"CZ"),
    (Text
"cy", forall a. a -> Maybe a
Just Text
"GB"),
    (Text
"da", forall a. a -> Maybe a
Just Text
"DK"),
    (Text
"de", forall a. a -> Maybe a
Just Text
"DE"),
    (Text
"el", forall a. a -> Maybe a
Just Text
"GR"),
    (Text
"en", forall a. a -> Maybe a
Just Text
"US"),
    (Text
"es", forall a. a -> Maybe a
Just Text
"ES"),
    (Text
"et", forall a. a -> Maybe a
Just Text
"EE"),
    (Text
"eu", forall a. Maybe a
Nothing),
    (Text
"fa", forall a. a -> Maybe a
Just Text
"IR"),
    (Text
"fi", forall a. a -> Maybe a
Just Text
"FI"),
    (Text
"fr", forall a. a -> Maybe a
Just Text
"FR"),
    (Text
"he", forall a. a -> Maybe a
Just Text
"IL"),
    (Text
"hr", forall a. a -> Maybe a
Just Text
"HR"),
    (Text
"hu", forall a. a -> Maybe a
Just Text
"HU"),
    (Text
"id", forall a. a -> Maybe a
Just Text
"ID"),
    (Text
"is", forall a. a -> Maybe a
Just Text
"IS"),
    (Text
"it", forall a. a -> Maybe a
Just Text
"IT"),
    (Text
"ja", forall a. a -> Maybe a
Just Text
"JP"),
    (Text
"km", forall a. a -> Maybe a
Just Text
"KH"),
    (Text
"ko", forall a. a -> Maybe a
Just Text
"KR"),
    (Text
"la", forall a. Maybe a
Nothing),
    (Text
"lt", forall a. a -> Maybe a
Just Text
"LT"),
    (Text
"lv", forall a. a -> Maybe a
Just Text
"LV"),
    (Text
"mn", forall a. a -> Maybe a
Just Text
"MN"),
    (Text
"nb", forall a. a -> Maybe a
Just Text
"NO"),
    (Text
"nl", forall a. a -> Maybe a
Just Text
"NL"),
    (Text
"nn", forall a. a -> Maybe a
Just Text
"NO"),
    (Text
"pl", forall a. a -> Maybe a
Just Text
"PL"),
    (Text
"pt", forall a. a -> Maybe a
Just Text
"PT"),
    (Text
"ro", forall a. a -> Maybe a
Just Text
"RO"),
    (Text
"ru", forall a. a -> Maybe a
Just Text
"RU"),
    (Text
"sk", forall a. a -> Maybe a
Just Text
"SK"),
    (Text
"sl", forall a. a -> Maybe a
Just Text
"SI"),
    (Text
"sr", forall a. a -> Maybe a
Just Text
"RS"),
    (Text
"sv", forall a. a -> Maybe a
Just Text
"SE"),
    (Text
"th", forall a. a -> Maybe a
Just Text
"TH"),
    (Text
"tr", forall a. a -> Maybe a
Just Text
"TR"),
    (Text
"uk", forall a. a -> Maybe a
Just Text
"UA"),
    (Text
"vi", forall a. a -> Maybe a
Just Text
"VN"),
    (Text
"zh", 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 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       -> forall a. Maybe a
Nothing
    Just Maybe Text
mbregion -> forall a. a -> Maybe a
Just 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 = 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 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 forall a. Eq a => a -> a -> Bool
== String
".xml"
     = let lang :: Text
lang = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String -> String
dropExtension String
fp
       in forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
lang (Text -> Either CiteprocError Locale
parseLocale 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 forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text
"-"forall a. Semigroup a => a -> a -> a
<>) (Lang -> Maybe Text
langRegion Lang
l)
   in case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Lang -> Text
toCode Lang
lang) Map Text (Either CiteprocError Locale)
locales
          forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Lang -> Maybe Lang
getPrimaryDialect Lang
lang forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
               (\Lang
l -> 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  -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> CiteprocError
CiteprocLocaleNotFound 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 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)]
_) -> forall a. a -> Maybe a
Just Text
t
     Maybe [(Term, 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 = forall a. a -> Maybe a -> a
fromMaybe Text
"\x201C" forall a b. (a -> b) -> a -> b
$ Locale -> Text -> Maybe Text
lookupTerm Locale
locale Text
"open-quote"
  outerClose :: Text
outerClose = forall a. a -> Maybe a -> a
fromMaybe Text
"\x201D" forall a b. (a -> b) -> a -> b
$ Locale -> Text -> Maybe Text
lookupTerm Locale
locale Text
"close-quote"
  innerOpen :: Text
innerOpen = forall a. a -> Maybe a -> a
fromMaybe Text
"\x2018" forall a b. (a -> b) -> a -> b
$ Locale -> Text -> Maybe Text
lookupTerm Locale
locale Text
"open-inner-quote"
  innerClose :: Text
innerClose = forall a. a -> Maybe a -> a
fromMaybe Text
"\x2019" forall a b. (a -> b) -> a -> b
$ Locale -> Text -> Maybe Text
lookupTerm Locale
locale Text
"close-inner-quote"