-- | Internal module for retrieving languages to localize to.
module Network.URI.Locale(rfc2616Locale) where

import System.Environment (lookupEnv)
import Control.Monad (forM)
import Data.Maybe (mapMaybe)
import Data.Char (toLower)

--- This file is based on logic in GNOME's LibSoup & GLib.

-- | Returns the languages to which responses should be localized.
-- Retrieved from Gettext configuration & reformatted for use in the
-- HTTP Accept-Language request header.
rfc2616Locale :: IO ([String], [String])
rfc2616Locale :: IO ([String], [String])
rfc2616Locale = do
    [Maybe String]
locales <- [String] -> (String -> IO (Maybe String)) -> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String
"LANGUAGE", String
"LC_ALL", String
"LC_MESSAGES", String
"LANG"] String -> IO (Maybe String)
lookupEnv
    let posix :: [String]
posix = String -> String -> [String]
forall (t :: * -> *) a. (Foldable t, Eq a) => t a -> [a] -> [[a]]
split String
":" (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ [Maybe String] -> String -> String
firstJust [Maybe String]
locales String
"en_US"
    let ietf :: [String]
ietf = (String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe String
toRFC2616Lang [String]
posix
    ([String], [String]) -> IO ([String], [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> [String]
explode [String]
ietf, [String] -> [String]
explode [String]
posix)

toRFC2616Lang :: String -> Maybe String
toRFC2616Lang String
"C" = Maybe String
forall a. Maybe a
Nothing
toRFC2616Lang (Char
'C':Char
'.':String
_) = Maybe String
forall a. Maybe a
Nothing
toRFC2616Lang (Char
'C':Char
'@':String
_) = Maybe String
forall a. Maybe a
Nothing
toRFC2616Lang String
lang = case String -> String
toRFC2616Lang' String
lang of
    String
"" -> Maybe String
forall a. Maybe a
Nothing
    String
lang' -> String -> Maybe String
forall a. a -> Maybe a
Just String
lang'

toRFC2616Lang' :: String -> String
toRFC2616Lang' (Char
'_':String
cs) = Char
'-' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toRFC2616Lang' String
cs
toRFC2616Lang' (Char
'.':String
_) = []
toRFC2616Lang' (Char
'@':String
_) = []
toRFC2616Lang' (Char
c:String
cs) = Char -> Char
toLower Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toRFC2616Lang' String
cs
toRFC2616Lang' [] = []

-- Makes sure to include the raw languages, and not just localized variants.
extractLangs :: [String] -> [String]
extractLangs (String
locale:[String]
locales) | (String
lang:[String]
_) <- String -> String -> [String]
forall (t :: * -> *) a. (Foldable t, Eq a) => t a -> [a] -> [[a]]
split String
"-_.@" String
locale = String
lang String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
extractLangs [String]
locales
extractLangs (String
_:[String]
locales) = [String] -> [String]
extractLangs [String]
locales
extractLangs [] = []

explode :: [String] -> [String]
explode [String]
locales = [String]
locales [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
l | String
l <- [String] -> [String]
extractLangs [String]
locales, String
l String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
locales]

firstJust :: [Maybe String] -> String -> String
firstJust (Just String
a:[Maybe String]
_) String
_ | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"" = String
a
firstJust (Maybe String
_:[Maybe String]
maybes) String
fallback = [Maybe String] -> String -> String
firstJust [Maybe String]
maybes String
fallback
firstJust [] String
fallback = String
fallback

split :: t a -> [a] -> [[a]]
split t a
b (a
a:[a]
as) | a
a a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
b = [] [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: t a -> [a] -> [[a]]
split t a
b [a]
as
        | ([a]
head':[[a]]
tail') <- t a -> [a] -> [[a]]
split t a
b [a]
as = (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
head') [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
tail'
        | Bool
otherwise = [a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as]
split t a
_ [] = [[]]