    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 mAcceptLanguage <- ((ByteString -> [Char]) -> Maybe ByteString -> Maybe [Char]
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ByteString -> [Char]
    C.unpack) (Maybe ByteString -> Maybe [Char])
    -> m (Maybe ByteString) -> m (Maybe [Char])
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Char] -> m (Maybe ByteString)
    forall (m :: * -> *).
    ServerMonad m =>
    [Char] -> m (Maybe ByteString)
    getHeaderM [Char]
    "Accept-Language"
           case mAcceptLanguage of
             Maybe [Char]
    Nothing   -> [(Text, Maybe Double)] -> m [(Text, Maybe Double)]
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
             (Just [Char]
    al) ->
                 case Parsec [Char] () [([Char], Maybe Double)]
    -> [Char] -> [Char] -> Either ParseError [([Char], Maybe Double)]
    forall s t a.
    Stream s Identity t =>
    Parsec s () a -> [Char] -> s -> Either ParseError a
    parse Parsec [Char] () [([Char], Maybe Double)]
    forall st. GenParser Char st [([Char], Maybe Double)]
    encodings [Char]
    al [Char]
    al of
                   (Left ParseError
    _) -> [(Text, Maybe Double)] -> m [(Text, Maybe Double)]
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
                   (Right [([Char], Maybe Double)]
    encs) -> [(Text, Maybe Double)] -> m [(Text, Maybe Double)]
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((([Char], Maybe Double) -> (Text, Maybe Double))
    -> [([Char], Maybe Double)] -> [(Text, Maybe Double)]
    forall a b. (a -> b) -> [a] -> [b]
    map (([Char] -> Text) -> ([Char], Maybe Double) -> (Text, Maybe Double)
    forall b c d. (b -> c) -> (b, d) -> (c, d)
    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
        ((Text, Maybe Double) -> (Text, Double))
    -> [(Text, Maybe Double)] -> [(Text, Double)]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Maybe Double -> Double) -> (Text, Maybe Double) -> (Text, Double)
    forall b c d. (b -> c) -> (d, b) -> (d, c)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (d, b) (d, c)
    second ((Maybe Double -> Double)
     -> (Text, Maybe Double) -> (Text, Double))
    -> (Maybe Double -> Double)
    -> (Text, Maybe Double)
    -> (Text, Double)
    forall a b. (a -> b) -> a -> b
    $ Double -> Maybe Double -> Double
    forall a. a -> Maybe a -> a
    fromMaybe Double
    1)     ([(Text, Maybe Double)] -> [(Text, Double)])
    -> ([(Text, Double)] -> [Text]) -> [(Text, Maybe Double)] -> [Text]
    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
        ((Text, Double) -> (Text, Double) -> Ordering)
    -> [(Text, Double)] -> [(Text, Double)]
    forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy ((Double -> Double -> Ordering) -> Double -> Double -> Ordering
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Double -> Double -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare (Double -> Double -> Ordering)
    -> ((Text, Double) -> Double)
    -> (Text, Double)
    -> (Text, Double)
    -> Ordering
    forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
    `on` (Text, Double) -> Double
    forall a b. (a, b) -> b
    snd) ([(Text, Double)] -> [(Text, Double)])
    -> ([(Text, Double)] -> [Text]) -> [(Text, Double)] -> [Text]
    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.
        ((Text, Double) -> Bool) -> [(Text, Double)] -> [(Text, Double)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (\(Text
    lang, Double
    q) -> Text
    lang Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    /= (Char -> Text
    Text.singleton Char
    '*') Bool -> Bool -> Bool
    && Double
    q Double -> Double -> Bool
    forall a. Ord a => a -> a -> Bool
    > Double
    0)  ([(Text, Double)] -> [(Text, Double)])
    -> ([(Text, Double)] -> [Text]) -> [(Text, Double)] -> [Text]
    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)
        ((Text, Double) -> [Text]) -> [(Text, Double)] -> [Text]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (Text -> [Text]
    explode (Text -> [Text])
    -> ((Text, Double) -> Text) -> (Text, Double) -> [Text]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Text, Double) -> Text
    forall a b. (a, b) -> a
    fst) ([(Text, Maybe Double)] -> [Text])
    -> [(Text, Maybe Double)] -> [Text]
    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 Text -> [Text] -> [Text]
    forall a. a -> [a] -> [a]
    : ([Text] -> [Text]
    forall a. [a] -> [a]
    reverse ([Text] -> [Text]) -> [Text] -> [Text]
    forall a b. (a -> b) -> a -> b
    $ ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map (Text, Text) -> Text
    forall a b. (a, b) -> a
    fst ([(Text, Text)] -> [Text]) -> [(Text, Text)] -> [Text]
    forall a b. (a -> b) -> a -> b
    $ HasCallStack => Text -> Text -> [(Text, Text)]
    Text -> Text -> [(Text, Text)]
    breakOnAll (Char -> Text
    singleton Char
    '-') Text
    lang)