{-# LANGUAGE OverloadedStrings #-}

module Network.Wai.Application.Classic.Lang (parseLang) where

import Control.Applicative hiding (optional)
import Data.Attoparsec.ByteString (Parser, takeWhile, parseOnly)
import Data.Attoparsec.ByteString.Char8 (char, string, count, space, digit, option, sepBy1)
import Data.ByteString.Char8 hiding (map, count, take, takeWhile, notElem)
import Data.List (sortBy)
import Data.Ord
import Prelude hiding (takeWhile)

-- |
-- >>> parseLang "en-gb;q=0.8, en;q=0.7, da"
-- ["da","en-gb","en"]

parseLang :: ByteString -> [ByteString]
parseLang :: ByteString -> [ByteString]
parseLang bs :: ByteString
bs = case Parser [(ByteString, Int)]
-> ByteString -> Either String [(ByteString, Int)]
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser [(ByteString, Int)]
acceptLanguage ByteString
bs of
    Right ls :: [(ByteString, Int)]
ls -> ((ByteString, Int) -> ByteString)
-> [(ByteString, Int)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Int) -> ByteString
forall a b. (a, b) -> a
fst ([(ByteString, Int)] -> [ByteString])
-> [(ByteString, Int)] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ((ByteString, Int) -> (ByteString, Int) -> Ordering)
-> [(ByteString, Int)] -> [(ByteString, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (ByteString, Int) -> (ByteString, Int) -> Ordering
forall a. (a, Int) -> (a, Int) -> Ordering
detrimental [(ByteString, Int)]
ls
    _        -> []
  where
    detrimental :: (a, Int) -> (a, Int) -> Ordering
detrimental = ((a, Int) -> (a, Int) -> Ordering)
-> (a, Int) -> (a, Int) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((a, Int) -> Int) -> (a, Int) -> (a, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (a, Int) -> Int
forall a b. (a, b) -> b
snd)

----------------------------------------------------------------

acceptLanguage :: Parser [(ByteString,Int)]
acceptLanguage :: Parser [(ByteString, Int)]
acceptLanguage = Parser (ByteString, Int)
rangeQvalue Parser (ByteString, Int)
-> Parser ByteString () -> Parser [(ByteString, Int)]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` (Parser ByteString ()
spaces Parser ByteString ()
-> Parser ByteString Char -> Parser ByteString Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser ByteString Char
char ',' Parser ByteString Char
-> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ()
spaces)

rangeQvalue :: Parser (ByteString,Int)
rangeQvalue :: Parser (ByteString, Int)
rangeQvalue = (,) (ByteString -> Int -> (ByteString, Int))
-> Parser ByteString ByteString
-> Parser ByteString (Int -> (ByteString, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
languageRange Parser ByteString (Int -> (ByteString, Int))
-> Parser ByteString Int -> Parser (ByteString, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Int
quality

languageRange :: Parser ByteString
languageRange :: Parser ByteString ByteString
languageRange = (Word8 -> Bool) -> Parser ByteString ByteString
takeWhile (Word8 -> [Word8] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [32, 44, 59])

quality :: Parser Int
quality :: Parser ByteString Int
quality = Int -> Parser ByteString Int -> Parser ByteString Int
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option 1000 (ByteString -> Parser ByteString ByteString
string ";q=" Parser ByteString ByteString
-> Parser ByteString Int -> Parser ByteString Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString Int
qvalue)

qvalue :: Parser Int
qvalue :: Parser ByteString Int
qvalue = 1000  Int -> Parser ByteString () -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  (Char -> Parser ByteString Char
char '1' Parser ByteString Char
-> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString String -> Parser ByteString ()
forall (f :: * -> *) b. (Alternative f, Monad f) => f b -> f ()
optional (Char -> Parser ByteString Char
char '.' Parser ByteString Char
-> Parser ByteString String -> Parser ByteString String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Int -> Parser ByteString Char -> Parser ByteString String
forall a. Int -> Int -> Parser a -> Parser [a]
range 0 3 Parser ByteString Char
digit))
     Parser ByteString Int
-> Parser ByteString Int -> Parser ByteString Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Int
forall c. Read c => String -> c
read3 (String -> Int)
-> Parser ByteString String -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser ByteString Char
char '0' Parser ByteString Char
-> Parser ByteString String -> Parser ByteString String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> Parser ByteString String -> Parser ByteString String
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option "0" (Char -> Parser ByteString Char
char '.' Parser ByteString Char
-> Parser ByteString String -> Parser ByteString String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Int -> Parser ByteString Char -> Parser ByteString String
forall a. Int -> Int -> Parser a -> Parser [a]
range 0 3 Parser ByteString Char
digit))
  where
    read3 :: String -> c
read3 n :: String
n = String -> c
forall c. Read c => String -> c
read (String -> c) -> (String -> String) -> String -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
take 3 (String -> c) -> String -> c
forall a b. (a -> b) -> a -> b
$ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
repeat '0'
    optional :: f b -> f ()
optional p :: f b
p = () () -> f b -> f ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f b
p f () -> f () -> f ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> f ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

----------------------------------------------------------------

range :: Int -> Int -> Parser a -> Parser [a]
range :: Int -> Int -> Parser a -> Parser [a]
range n :: Int
n m :: Int
m p :: Parser a
p = [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) ([a] -> [a] -> [a]) -> Parser [a] -> Parser ByteString ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser a -> Parser [a]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
n Parser a
p Parser ByteString ([a] -> [a]) -> Parser [a] -> Parser [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Parser a -> Parser [a]
forall a. Int -> Parser a -> Parser [a]
upto (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Parser a
p

upto :: Int -> Parser a -> Parser [a]
upto :: Int -> Parser a -> Parser [a]
upto 0 _ = [a] -> Parser [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
upto n :: Int
n p :: Parser a
p = (:) (a -> [a] -> [a]) -> Parser a -> Parser ByteString ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
p Parser ByteString ([a] -> [a]) -> Parser [a] -> Parser [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Parser a -> Parser [a]
forall a. Int -> Parser a -> Parser [a]
upto (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Parser a
p Parser [a] -> Parser [a] -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> Parser [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []

spaces :: Parser ()
spaces :: Parser ByteString ()
spaces = () () -> Parser ByteString String -> Parser ByteString ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ByteString Char -> Parser ByteString String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ByteString Char
space