module Happstack.Server.I18N
     ( acceptLanguage
     , bestLanguage
     ) where

import Control.Arrow ((>>>), first, second)
import Data.Function (on)
import qualified Data.ByteString.Char8 as C
import Data.List     (sortBy)
import Data.Maybe    (fromMaybe)
import Data.Text     as Text (Text, breakOnAll, pack, singleton)
import Happstack.Server.Monads (Happstack, getHeaderM)
import Happstack.Server.Internal.Compression (encodings)
import Text.ParserCombinators.Parsec (parse)

-- TODO: proper Accept-Language parser

-- | parse the 'Accept-Language' header, or [] if not found.
acceptLanguage :: (Happstack m) => m [(Text, Maybe Double)]
acceptLanguage :: forall (m :: * -> *). Happstack m => m [(Text, Maybe Double)]
acceptLanguage =
    do Maybe [Char]
mAcceptLanguage <- (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> [Char]
C.unpack) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
ServerMonad m =>
[Char] -> m (Maybe ByteString)
getHeaderM [Char]
"Accept-Language"
       case Maybe [Char]
mAcceptLanguage of
         Maybe [Char]
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return []
         (Just [Char]
al) ->
             case forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse forall st. GenParser Char st [([Char], Maybe Double)]
encodings [Char]
al [Char]
al of
               (Left ParseError
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return []
               (Right [([Char], Maybe Double)]
encs) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first [Char] -> Text
Text.pack) [([Char], Maybe Double)]
encs)

-- | deconstruct the 'acceptLanguage' results a return a list of
-- languages sorted by preference in descending order.
--
-- Note: this implementation does not conform to RFC4647
--
-- Among other things, it does not handle wildcards. A proper
-- implementation needs to take a list of available languages.
bestLanguage :: [(Text, Maybe Double)] -> [Text]
bestLanguage :: [(Text, Maybe Double)] -> [Text]
bestLanguage [(Text, Maybe Double)]
range =
    -- is no 'q' param, set 'q' to 1.0
    forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Double
1)     forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
    -- sort in descending order
    forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> b
snd) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
    -- remove entries with '*' or q == 0. Removing '*' entries is not
    -- technically correct, but it is the best we can do with out a
    -- list of available languages.
    forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
lang, Double
q) -> Text
lang forall a. Eq a => a -> a -> Bool
/= (Char -> Text
Text.singleton Char
'*') Bool -> Bool -> Bool
&& Double
q forall a. Ord a => a -> a -> Bool
> Double
0)  forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
    -- lookup fallback (RFC 4647, Section 3.4)
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> [Text]
explode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
    [(Text, Maybe Double)]
range
    where
      -- | example: "en-us-gb" -> ["en-us-gb","en-us","en"]
      explode :: Text -> [Text]
      explode :: Text -> [Text]
explode Text
lang = Text
lang forall a. a -> [a] -> [a]
: (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Text -> Text -> [(Text, Text)]
breakOnAll (Char -> Text
singleton Char
'-') Text
lang)