{-# 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 ByteString
bs = case Parser [(ByteString, Int)]
-> ByteString -> Either [Char] [(ByteString, Int)]
forall a. Parser a -> ByteString -> Either [Char] a
parseOnly Parser [(ByteString, Int)]
acceptLanguage ByteString
bs of
    Right [(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
    Either [Char] [(ByteString, Int)]
_        -> []
  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 a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser ByteString Char
char Char
',' Parser ByteString Char
-> Parser ByteString () -> Parser ByteString ()
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
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 a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
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` [Word8
32, Word8
44, Word8
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 Int
1000 (ByteString -> Parser ByteString ByteString
string ByteString
";q=" Parser ByteString ByteString
-> Parser ByteString Int -> Parser ByteString Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString Int
qvalue)

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

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

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

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