{-# 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 String [(ByteString, Int)]
forall a. Parser a -> ByteString -> Either String 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 String [(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 (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 (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` [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 (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 (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 (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 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 Int
0 Int
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 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 String
"0" (Char -> Parser ByteString Char
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 Int
0 Int
3 Parser ByteString Char
digit))
  where
    read3 :: String -> c
read3 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 Int
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 Char
'0'
    optional :: f b -> f ()
optional 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 Int
n Int
m 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 Int
0 Parser a
_ = [a] -> Parser [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 [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
- Int
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