module Network.Web.Server.Lang (parseLang) where

import Control.Applicative hiding (many,optional,(<|>))
import Data.List
import Data.Ord
import Text.Parsec
import Text.Parsec.String

parseLang :: String -> [String]
parseLang xs = case parse acceptLanguage "" xs of
    Left   _ -> []
    Right ls -> map fst $ sortBy detrimental ls
  where
    detrimental = flip (comparing snd)

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

acceptLanguage :: Parser [(String,Int)]
acceptLanguage = rangeQvalue `sepBy1` (spaces *> char ',' *> spaces)

rangeQvalue :: Parser (String,Int)
rangeQvalue = (,) <$> languageRange <*> quality

languageRange :: Parser String
languageRange = (++) <$> language <*> sublang

language :: Parser String
language = many1 letter

sublang :: Parser String
sublang = option "" ((:) <$> char '-' <*> many1 letter)

quality :: Parser Int
quality = option 1000 (string ";q=" *> qvalue)

qvalue :: Parser Int
qvalue = 1000  <$  (char '1' *> optional (char '.' *> range 0 3 digit))
     <|> read3 <$> (char '0' *> option "0" (char '.' *> range 0 3 digit))
  where
    read3 n = read . take 3 $ n ++ repeat '0'

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

range :: Int -> Int -> GenParser tok st a -> GenParser tok st [a]
range n m p = (++) <$> count n p <*> upto (m - n) p

upto :: Int -> GenParser tok st a -> GenParser tok st [a]
upto 0 _ = return []
upto n p = (:) <$> p <*> upto (n - 1) p <|> return []