module Network.CGI.Accept (
  -- * Accept-X headers
    Acceptable
  , Accept
  , Charset(..), ContentEncoding(..), Language(..)
  -- * Content negotiation
  , negotiate
                          ) where

import Data.Function
import Data.List
import Data.Maybe
import Numeric

import Text.ParserCombinators.Parsec

import Network.Multipart
import Network.Multipart.Header


--
-- * Accept-X headers
--

newtype Accept a = Accept [(a, Quality)]
    deriving (Int -> Accept a -> ShowS
[Accept a] -> ShowS
Accept a -> String
(Int -> Accept a -> ShowS)
-> (Accept a -> String) -> ([Accept a] -> ShowS) -> Show (Accept a)
forall a. Show a => Int -> Accept a -> ShowS
forall a. Show a => [Accept a] -> ShowS
forall a. Show a => Accept a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Accept a -> ShowS
showsPrec :: Int -> Accept a -> ShowS
$cshow :: forall a. Show a => Accept a -> String
show :: Accept a -> String
$cshowList :: forall a. Show a => [Accept a] -> ShowS
showList :: [Accept a] -> ShowS
Show)

type Quality = Double

-- A bounded join-semilattice
class Eq a => Acceptable a where
    includes :: a -> a -> Bool

instance HeaderValue a => HeaderValue (Accept a) where
    parseHeaderValue :: Parser (Accept a)
parseHeaderValue = [(a, Quality)] -> Accept a
forall a. [(a, Quality)] -> Accept a
Accept ([(a, Quality)] -> Accept a)
-> ParsecT String () Identity [(a, Quality)] -> Parser (Accept a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity (a, Quality)
-> ParsecT String () Identity Char
-> ParsecT String () Identity [(a, Quality)]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy ParsecT String () Identity (a, Quality)
p (ParsecT String () Identity Char -> ParsecT String () Identity Char
forall a. Parser a -> Parser a
lexeme (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
','))
        where p :: ParsecT String () Identity (a, Quality)
p = do a
a <- Parser a
forall a. HeaderValue a => Parser a
parseHeaderValue
                     Quality
q <- Quality
-> ParsecT String () Identity Quality
-> ParsecT String () Identity Quality
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Quality
1 (ParsecT String () Identity Quality
 -> ParsecT String () Identity Quality)
-> ParsecT String () Identity Quality
-> ParsecT String () Identity Quality
forall a b. (a -> b) -> a -> b
$ do Char
_ <- ParsecT String () Identity Char -> ParsecT String () Identity Char
forall a. Parser a -> Parser a
lexeme (ParsecT String () Identity Char
 -> ParsecT String () Identity Char)
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
';'
                                        Char
_ <- ParsecT String () Identity Char -> ParsecT String () Identity Char
forall a. Parser a -> Parser a
lexeme (ParsecT String () Identity Char
 -> ParsecT String () Identity Char)
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'q'
                                        Char
_ <- ParsecT String () Identity Char -> ParsecT String () Identity Char
forall a. Parser a -> Parser a
lexeme (ParsecT String () Identity Char
 -> ParsecT String () Identity Char)
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'='
                                        ParsecT String () Identity Quality
-> ParsecT String () Identity Quality
forall a. Parser a -> Parser a
lexeme ParsecT String () Identity Quality
forall {u}. ParsecT String u Identity Quality
pQuality
                     (a, Quality) -> ParsecT String () Identity (a, Quality)
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,Quality
q)
              pQuality :: ParsecT String u Identity Quality
pQuality = (Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'0' ParsecT String u Identity Char
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option String
"0" (Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.' ParsecT String u Identity Char
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String u Identity Char -> ParsecT String u Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit) ParsecT String u Identity String
-> (String -> ParsecT String u Identity Quality)
-> ParsecT String u Identity Quality
forall a b.
ParsecT String u Identity a
-> (a -> ParsecT String u Identity b)
-> ParsecT String u Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
ds -> Quality -> ParsecT String u Identity Quality
forall a. a -> ParsecT String u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Quality
forall a. Read a => String -> a
read (String
"0." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ds String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"0")))
                         ParsecT String u Identity Quality
-> ParsecT String u Identity Quality
-> ParsecT String u Identity Quality
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'1' ParsecT String u Identity Char
-> ParsecT String u Identity () -> ParsecT String u Identity ()
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String u Identity String -> ParsecT String u Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional (Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.' ParsecT String u Identity Char
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String u Identity Char -> ParsecT String u Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'0')) ParsecT String u Identity ()
-> ParsecT String u Identity Quality
-> ParsecT String u Identity Quality
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Quality -> ParsecT String u Identity Quality
forall a. a -> ParsecT String u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Quality
1)
    prettyHeaderValue :: Accept a -> String
prettyHeaderValue (Accept [(a, Quality)]
xs) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [a -> String
forall a. HeaderValue a => a -> String
prettyHeaderValue a
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"; q=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Quality -> String
forall {a}. RealFloat a => a -> String
showQuality Quality
q | (a
a,Quality
q) <- [(a, Quality)]
xs]
        where showQuality :: a -> String
showQuality a
q = Maybe Int -> a -> ShowS
forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloat (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
3) a
q String
""

starOrEqualTo :: String -> String -> Bool
starOrEqualTo :: String -> String -> Bool
starOrEqualTo String
x String
y = String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"*" Bool -> Bool -> Bool
|| String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y


negotiate :: Acceptable a => [a] -> Maybe (Accept a) -> [a]
negotiate :: forall a. Acceptable a => [a] -> Maybe (Accept a) -> [a]
negotiate [a]
ys Maybe (Accept a)
Nothing = [a]
ys
negotiate [a]
ys (Just Accept a
xs) = [a] -> [a]
forall a. [a] -> [a]
reverse [ a
z | (Quality
q,a
z) <- ((Quality, a) -> (Quality, a) -> Ordering)
-> [(Quality, a)] -> [(Quality, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Quality -> Quality -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Quality -> Quality -> Ordering)
-> ((Quality, a) -> Quality)
-> (Quality, a)
-> (Quality, a)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Quality, a) -> Quality
forall a b. (a, b) -> a
fst) [ (Accept a -> a -> Quality
forall a. Acceptable a => Accept a -> a -> Quality
quality Accept a
xs a
y,a
y) | a
y <- [a]
ys], Quality
q Quality -> Quality -> Bool
forall a. Ord a => a -> a -> Bool
> Quality
0]

--testNegotiate :: (HeaderValue a, Acceptable a) => [String] -> String -> [a]
--testNegotiate ts a = negotiate [t | Just t <- map (parseM parseHeaderValue "<source>") ts] (parseM parseHeaderValue "<source>" a)

quality :: Acceptable a => Accept a -> a -> Quality
quality :: forall a. Acceptable a => Accept a -> a -> Quality
quality (Accept [(a, Quality)]
xs) a
y = Quality -> Maybe Quality -> Quality
forall a. a -> Maybe a -> a
fromMaybe Quality
0 (Maybe Quality -> Quality) -> Maybe Quality -> Quality
forall a b. (a -> b) -> a -> b
$ [Quality] -> Maybe Quality
forall a. [a] -> Maybe a
listToMaybe ([Quality] -> Maybe Quality) -> [Quality] -> Maybe Quality
forall a b. (a -> b) -> a -> b
$ [Quality] -> [Quality]
forall a. Ord a => [a] -> [a]
sort ([Quality] -> [Quality]) -> [Quality] -> [Quality]
forall a b. (a -> b) -> a -> b
$ ((a, Quality) -> Quality) -> [(a, Quality)] -> [Quality]
forall a b. (a -> b) -> [a] -> [b]
map (a, Quality) -> Quality
forall a b. (a, b) -> b
snd ([(a, Quality)] -> [Quality]) -> [(a, Quality)] -> [Quality]
forall a b. (a -> b) -> a -> b
$ ((a, Quality) -> (a, Quality) -> Ordering)
-> [(a, Quality)] -> [(a, Quality)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (a -> a -> Ordering
forall a. Acceptable a => a -> a -> Ordering
compareSpecificity (a -> a -> Ordering)
-> ((a, Quality) -> a) -> (a, Quality) -> (a, Quality) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (a, Quality) -> a
forall a b. (a, b) -> a
fst) ([(a, Quality)] -> [(a, Quality)])
-> [(a, Quality)] -> [(a, Quality)]
forall a b. (a -> b) -> a -> b
$ ((a, Quality) -> Bool) -> [(a, Quality)] -> [(a, Quality)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a -> a -> Bool
forall a. Acceptable a => a -> a -> Bool
`includes` a
y) (a -> Bool) -> ((a, Quality) -> a) -> (a, Quality) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Quality) -> a
forall a b. (a, b) -> a
fst) [(a, Quality)]
xs

compareSpecificity :: Acceptable a => a -> a -> Ordering
compareSpecificity :: forall a. Acceptable a => a -> a -> Ordering
compareSpecificity a
x a
y
    | a
x a -> a -> Bool
forall a. Acceptable a => a -> a -> Bool
`includes` a
y Bool -> Bool -> Bool
&& a
y a -> a -> Bool
forall a. Acceptable a => a -> a -> Bool
`includes` a
x = Ordering
EQ
    | a
x a -> a -> Bool
forall a. Acceptable a => a -> a -> Bool
`includes` a
y = Ordering
GT
    | a
y a -> a -> Bool
forall a. Acceptable a => a -> a -> Bool
`includes` a
x = Ordering
LT
    | Bool
otherwise = String -> Ordering
forall a. HasCallStack => String -> a
error String
"Non-comparable Acceptables"

--
-- ** Accept
--

instance Acceptable ContentType where
    includes :: ContentType -> ContentType -> Bool
includes ContentType
x ContentType
y = ContentType -> String
ctType ContentType
x String -> String -> Bool
`starOrEqualTo` ContentType -> String
ctType ContentType
y
                   Bool -> Bool -> Bool
&& ContentType -> String
ctSubtype ContentType
x String -> String -> Bool
`starOrEqualTo` ContentType -> String
ctSubtype ContentType
y
                   Bool -> Bool -> Bool
&& ((String, String) -> Bool) -> [(String, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ContentType -> (String, String) -> Bool
hasParameter ContentType
y) (ContentType -> [(String, String)]
ctParameters ContentType
x)

hasParameter :: ContentType -> (String, String) -> Bool
hasParameter :: ContentType -> (String, String) -> Bool
hasParameter ContentType
t (String
k,String
v) = (Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
v) (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
k (ContentType -> [(String, String)]
ctParameters ContentType
t)

--
-- ** Accept-Charset
--

{-
RFC 2616 14.2:

The special value "*", if present in the Accept-Charset field, matches
every character set (including ISO-8859-1) which is not mentioned
elsewhere in the Accept-Charset field. If no "*" is present in an
Accept-Charset field, then all character sets not explicitly mentioned
get a quality value of 0, except for ISO-8859-1, which gets a quality
value of 1 if not explicitly mentioned.

If no Accept-Charset header is present, the default is that any
character set is acceptable. If an Accept-Charset header is present,
and if the server cannot send a response which is acceptable according
to the Accept-Charset header, then the server SHOULD send an error
response with the 406 (not acceptable) status code, though the sending
of an unacceptable response is also allowed.
-}

newtype Charset = Charset String
    deriving (Int -> Charset -> ShowS
[Charset] -> ShowS
Charset -> String
(Int -> Charset -> ShowS)
-> (Charset -> String) -> ([Charset] -> ShowS) -> Show Charset
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Charset -> ShowS
showsPrec :: Int -> Charset -> ShowS
$cshow :: Charset -> String
show :: Charset -> String
$cshowList :: [Charset] -> ShowS
showList :: [Charset] -> ShowS
Show)

instance Eq Charset where
    Charset String
x == :: Charset -> Charset -> Bool
== Charset String
y = String -> String -> Bool
caseInsensitiveEq String
x String
y

instance Ord Charset where
    Charset String
x compare :: Charset -> Charset -> Ordering
`compare` Charset String
y = String -> String -> Ordering
caseInsensitiveCompare String
x String
y

instance HeaderValue Charset where
    parseHeaderValue :: Parser Charset
parseHeaderValue = (String -> Charset)
-> ParsecT String () Identity String -> Parser Charset
forall a b.
(a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Charset
Charset (ParsecT String () Identity String -> Parser Charset)
-> ParsecT String () Identity String -> Parser Charset
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Char
ws1 ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a. Parser a -> Parser a
lexeme ParsecT String () Identity String
p_token
    prettyHeaderValue :: Charset -> String
prettyHeaderValue (Charset String
s) = String
s

instance Acceptable Charset where
    Charset String
x includes :: Charset -> Charset -> Bool
`includes` Charset String
y = String -> String -> Bool
starOrEqualTo String
x String
y

--
-- ** Accept-Encoding
--

{-
RFC 2616, section 14.3
-}

newtype ContentEncoding = ContentEncoding String
    deriving (Int -> ContentEncoding -> ShowS
[ContentEncoding] -> ShowS
ContentEncoding -> String
(Int -> ContentEncoding -> ShowS)
-> (ContentEncoding -> String)
-> ([ContentEncoding] -> ShowS)
-> Show ContentEncoding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ContentEncoding -> ShowS
showsPrec :: Int -> ContentEncoding -> ShowS
$cshow :: ContentEncoding -> String
show :: ContentEncoding -> String
$cshowList :: [ContentEncoding] -> ShowS
showList :: [ContentEncoding] -> ShowS
Show)

instance Eq ContentEncoding where
    ContentEncoding String
x == :: ContentEncoding -> ContentEncoding -> Bool
== ContentEncoding String
y = String -> String -> Bool
caseInsensitiveEq String
x String
y

instance Ord ContentEncoding where
    ContentEncoding String
x compare :: ContentEncoding -> ContentEncoding -> Ordering
`compare` ContentEncoding String
y = String -> String -> Ordering
caseInsensitiveCompare String
x String
y

instance HeaderValue ContentEncoding where
    parseHeaderValue :: Parser ContentEncoding
parseHeaderValue = (String -> ContentEncoding)
-> ParsecT String () Identity String -> Parser ContentEncoding
forall a b.
(a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> ContentEncoding
ContentEncoding (ParsecT String () Identity String -> Parser ContentEncoding)
-> ParsecT String () Identity String -> Parser ContentEncoding
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Char
ws1 ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a. Parser a -> Parser a
lexeme ParsecT String () Identity String
p_token
    prettyHeaderValue :: ContentEncoding -> String
prettyHeaderValue (ContentEncoding String
s) = String
s

instance Acceptable ContentEncoding where
    ContentEncoding String
x includes :: ContentEncoding -> ContentEncoding -> Bool
`includes` ContentEncoding String
y = String -> String -> Bool
starOrEqualTo String
x String
y

--
-- ** Accept-Language
--

newtype Language = Language String
    deriving (Int -> Language -> ShowS
[Language] -> ShowS
Language -> String
(Int -> Language -> ShowS)
-> (Language -> String) -> ([Language] -> ShowS) -> Show Language
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Language -> ShowS
showsPrec :: Int -> Language -> ShowS
$cshow :: Language -> String
show :: Language -> String
$cshowList :: [Language] -> ShowS
showList :: [Language] -> ShowS
Show)

instance Eq Language where
    Language String
x == :: Language -> Language -> Bool
== Language String
y = String -> String -> Bool
caseInsensitiveEq String
x String
y

instance Ord Language where
    Language String
x compare :: Language -> Language -> Ordering
`compare` Language String
y = String -> String -> Ordering
caseInsensitiveCompare String
x String
y

instance HeaderValue Language where
    parseHeaderValue :: Parser Language
parseHeaderValue = (String -> Language)
-> ParsecT String () Identity String -> Parser Language
forall a b.
(a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Language
Language (ParsecT String () Identity String -> Parser Language)
-> ParsecT String () Identity String -> Parser Language
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Char
ws1 ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a. Parser a -> Parser a
lexeme ParsecT String () Identity String
p_token
    prettyHeaderValue :: Language -> String
prettyHeaderValue (Language String
s) = String
s

{-
RFC 2616 14.4

A language-range matches a language-tag if it exactly equals the tag,
or if it exactly equals a prefix of the tag such that the first tag
character following the prefix is "-". The special range "*", if
present in the Accept-Language field, matches every tag not matched by
any other range present in the Accept-Language field.
-}
instance Acceptable Language where
    Language String
x includes :: Language -> Language -> Bool
`includes` Language String
y =
        String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"*" Bool -> Bool -> Bool
|| String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y Bool -> Bool -> Bool
|| (String
x String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
y Bool -> Bool -> Bool
&& String
"-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x) String
y)