    {-# LANGUAGE DeriveFunctor #-}

    -- | Defines the quality value data type.
    module Network.HTTP.Media.Quality
      ( Quality (..),
        quality,
        QualityOrder,
        qualityOrder,
        isAcceptable,
        maxQuality,
        minQuality,
        mostSpecific,
        showQ,
        readQ,
      )
    where

    import Data.ByteString (ByteString)
    import qualified Data.ByteString.Char8 as BS
    import Data.ByteString.UTF8 (toString)
    import Data.Char (isDigit)
    import Data.List (dropWhileEnd)
    import Data.Maybe (fromMaybe)
    import Data.Monoid ((<>))
    import Data.Word (Word16, Word32)
    import Network.HTTP.Media.Accept (Accept, moreSpecificThan)
    import Network.HTTP.Media.RenderHeader (RenderHeader (..))
    import Prelude hiding ((<>))

    -- | Attaches a quality value to data.
    data Quality a = Quality
      { forall a. Quality a -> a
    qualityData :: a,
        forall a. Quality a -> Word16
    qualityValue :: Word16
      }
      deriving (Quality a -> Quality a -> Bool
    (Quality a -> Quality a -> Bool)
    -> (Quality a -> Quality a -> Bool) -> Eq (Quality a)
    forall a. Eq a => Quality a -> Quality a -> Bool
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: forall a. Eq a => Quality a -> Quality a -> Bool
    == :: Quality a -> Quality a -> Bool
    $c/= :: forall a. Eq a => Quality a -> Quality a -> Bool
    /= :: Quality a -> Quality a -> Bool
    Eq, (forall a b. (a -> b) -> Quality a -> Quality b)
    -> (forall a b. a -> Quality b -> Quality a) -> Functor Quality
    forall a b. a -> Quality b -> Quality a
    forall a b. (a -> b) -> Quality a -> Quality b
    forall (f :: * -> *).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    $cfmap :: forall a b. (a -> b) -> Quality a -> Quality b
    fmap :: forall a b. (a -> b) -> Quality a -> Quality b
    $c<$ :: forall a b. a -> Quality b -> Quality a
    <$ :: forall a b. a -> Quality b -> Quality a
    Functor, Eq (Quality a)
    Eq (Quality a) =>
    (Quality a -> Quality a -> Ordering)
    -> (Quality a -> Quality a -> Bool)
    -> (Quality a -> Quality a -> Bool)
    -> (Quality a -> Quality a -> Bool)
    -> (Quality a -> Quality a -> Bool)
    -> (Quality a -> Quality a -> Quality a)
    -> (Quality a -> Quality a -> Quality a)
    -> Ord (Quality a)
    Quality a -> Quality a -> Bool
    Quality a -> Quality a -> Ordering
    Quality a -> Quality a -> Quality a
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    forall a. Ord a => Eq (Quality a)
    forall a. Ord a => Quality a -> Quality a -> Bool
    forall a. Ord a => Quality a -> Quality a -> Ordering
    forall a. Ord a => Quality a -> Quality a -> Quality a
    $ccompare :: forall a. Ord a => Quality a -> Quality a -> Ordering
    compare :: Quality a -> Quality a -> Ordering
    $c< :: forall a. Ord a => Quality a -> Quality a -> Bool
    < :: Quality a -> Quality a -> Bool
    $c<= :: forall a. Ord a => Quality a -> Quality a -> Bool
    <= :: Quality a -> Quality a -> Bool
    $c> :: forall a. Ord a => Quality a -> Quality a -> Bool
    > :: Quality a -> Quality a -> Bool
    $c>= :: forall a. Ord a => Quality a -> Quality a -> Bool
    >= :: Quality a -> Quality a -> Bool
    $cmax :: forall a. Ord a => Quality a -> Quality a -> Quality a
    max :: Quality a -> Quality a -> Quality a
    $cmin :: forall a. Ord a => Quality a -> Quality a -> Quality a
    min :: Quality a -> Quality a -> Quality a
    Ord)

    instance (RenderHeader a) => Show (Quality a) where
      show :: Quality a -> String
    show = ByteString -> String
    BS.unpack (ByteString -> String)
    -> (Quality a -> ByteString) -> Quality a -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Quality a -> ByteString
    forall h. RenderHeader h => h -> ByteString
    renderHeader

    instance (RenderHeader h) => RenderHeader (Quality h) where
      renderHeader :: Quality h -> ByteString
    renderHeader (Quality h
    a Word16
    q) = h -> ByteString
    forall h. RenderHeader h => h -> ByteString
    renderHeader h
    a ByteString -> ByteString -> ByteString
    forall a. Semigroup a => a -> a -> a
    <> ByteString
    ";q=" ByteString -> ByteString -> ByteString
    forall a. Semigroup a => a -> a -> a
    <> Word16 -> ByteString
    showQ Word16
    q

    -- | Manually construct a quality value.
    quality :: a -> ByteString -> Quality a
    quality :: forall a. a -> ByteString -> Quality a
    quality a
    x ByteString
    q =
      a -> Word16 -> Quality a
    forall a. a -> Word16 -> Quality a
    Quality a
    x (Word16 -> Quality a) -> Word16 -> Quality a
    forall a b. (a -> b) -> a -> b
    $
        (Word16 -> Maybe Word16 -> Word16)
    -> Maybe Word16 -> Word16 -> Word16
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Word16 -> Maybe Word16 -> Word16
    forall a. a -> Maybe a -> a
    fromMaybe (ByteString -> Maybe Word16
    readQ ByteString
    q) (Word16 -> Word16) -> Word16 -> Word16
    forall a b. (a -> b) -> a -> b
    $
          String -> Word16
    forall a. HasCallStack => String -> a
    error (String
    "Invalid quality value " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ ByteString -> String
    toString ByteString
    q)

    -- | An opaque ordered representation of quality values without attached data.
    newtype QualityOrder = QualityOrder Word16
      deriving (QualityOrder -> QualityOrder -> Bool
    (QualityOrder -> QualityOrder -> Bool)
    -> (QualityOrder -> QualityOrder -> Bool) -> Eq QualityOrder
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: QualityOrder -> QualityOrder -> Bool
    == :: QualityOrder -> QualityOrder -> Bool
    $c/= :: QualityOrder -> QualityOrder -> Bool
    /= :: QualityOrder -> QualityOrder -> Bool
    Eq, Eq QualityOrder
    Eq QualityOrder =>
    (QualityOrder -> QualityOrder -> Ordering)
    -> (QualityOrder -> QualityOrder -> Bool)
    -> (QualityOrder -> QualityOrder -> Bool)
    -> (QualityOrder -> QualityOrder -> Bool)
    -> (QualityOrder -> QualityOrder -> Bool)
    -> (QualityOrder -> QualityOrder -> QualityOrder)
    -> (QualityOrder -> QualityOrder -> QualityOrder)
    -> Ord QualityOrder
    QualityOrder -> QualityOrder -> Bool
    QualityOrder -> QualityOrder -> Ordering
    QualityOrder -> QualityOrder -> QualityOrder
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: QualityOrder -> QualityOrder -> Ordering
    compare :: QualityOrder -> QualityOrder -> Ordering
    $c< :: QualityOrder -> QualityOrder -> Bool
    < :: QualityOrder -> QualityOrder -> Bool
    $c<= :: QualityOrder -> QualityOrder -> Bool
    <= :: QualityOrder -> QualityOrder -> Bool
    $c> :: QualityOrder -> QualityOrder -> Bool
    > :: QualityOrder -> QualityOrder -> Bool
    $c>= :: QualityOrder -> QualityOrder -> Bool
    >= :: QualityOrder -> QualityOrder -> Bool
    $cmax :: QualityOrder -> QualityOrder -> QualityOrder
    max :: QualityOrder -> QualityOrder -> QualityOrder
    $cmin :: QualityOrder -> QualityOrder -> QualityOrder
    min :: QualityOrder -> QualityOrder -> QualityOrder
    Ord)

    -- | Whether the quality value is greater than zero; otherwise the value
    -- should never be accepted, even when no other options are available.
    isAcceptable :: Quality a -> Bool
    isAcceptable :: forall a. Quality a -> Bool
    isAcceptable (Quality a
    _ Word16
    0) = Bool
    False
    isAcceptable (Quality a
    _ Word16
    _) = Bool
    True

    -- | Remove the attached data from a quality value, retaining only the
    -- priority of the quality parameter.
    qualityOrder :: Quality a -> QualityOrder
    qualityOrder :: forall a. Quality a -> QualityOrder
    qualityOrder = Word16 -> QualityOrder
    QualityOrder (Word16 -> QualityOrder)
    -> (Quality a -> Word16) -> Quality a -> QualityOrder
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Quality a -> Word16
    forall a. Quality a -> Word16
    qualityValue

    -- | Attaches the quality value '1'.
    maxQuality :: a -> Quality a
    maxQuality :: forall a. a -> Quality a
    maxQuality = (a -> Word16 -> Quality a) -> Word16 -> a -> Quality a
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip a -> Word16 -> Quality a
    forall a. a -> Word16 -> Quality a
    Quality Word16
    1000

    -- | Attaches the quality value '0'.
    minQuality :: a -> Quality a
    minQuality :: forall a. a -> Quality a
    minQuality = (a -> Word16 -> Quality a) -> Word16 -> a -> Quality a
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip a -> Word16 -> Quality a
    forall a. a -> Word16 -> Quality a
    Quality Word16
    0

    -- | Combines quality values by specificity. Selects the more specific of the
    -- two arguments, but if they are the same returns the data of the left
    -- argument with the two quality values of both arguments combined.
    mostSpecific :: (Accept a) => Quality a -> Quality a -> Quality a
    mostSpecific :: forall a. Accept a => Quality a -> Quality a -> Quality a
    mostSpecific (Quality a
    a Word16
    q) (Quality a
    b Word16
    r)
      | a
    a a -> a -> Bool
    forall a. Accept a => a -> a -> Bool
    `moreSpecificThan` a
    b = a -> Word16 -> Quality a
    forall a. a -> Word16 -> Quality a
    Quality a
    a Word16
    q
      | a
    b a -> a -> Bool
    forall a. Accept a => a -> a -> Bool
    `moreSpecificThan` a
    a = a -> Word16 -> Quality a
    forall a. a -> Word16 -> Quality a
    Quality a
    b Word16
    r
      | Bool
    otherwise = a -> Word16 -> Quality a
    forall a. a -> Word16 -> Quality a
    Quality a
    a Word16
    q'
      where
        q' :: Word16
    q' = Word32 -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word16 -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word16
    q Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    * Word16 -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word16
    r Word32 -> Word32 -> Word32
    forall a. Integral a => a -> a -> a
    `div` Word32
    1000 :: Word32)

    -- | Converts the integral value into its standard quality representation.
    showQ :: Word16 -> ByteString
    showQ :: Word16 -> ByteString
    showQ Word16
    1000 = ByteString
    "1"
    showQ Word16
    0 = ByteString
    "0"
    showQ Word16
    q = ByteString
    "0." ByteString -> ByteString -> ByteString
    forall a. Semigroup a => a -> a -> a
    <> Int -> Char -> ByteString
    BS.replicate (Int
    3 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    s) Char
    '0' ByteString -> ByteString -> ByteString
    forall a. Semigroup a => a -> a -> a
    <> ByteString
    b
      where
        s :: String
    s = Word16 -> String
    forall a. Show a => a -> String
    show Word16
    q
        b :: ByteString
    b = String -> ByteString
    BS.pack ((Char -> Bool) -> ShowS
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhileEnd (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '0') String
    s)

    -- | Reads the standard quality representation into an integral value.
    readQ :: ByteString -> Maybe Word16
    readQ :: ByteString -> Maybe Word16
    readQ ByteString
    bs
      | ByteString -> Bool
    BS.null ByteString
    bs = Maybe Word16
    forall a. Maybe a
    Nothing
      | Char
    h Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '1' = ByteString -> Maybe Word16
    read1 ByteString
    t
      | Char
    h Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '0' = ByteString -> Maybe Word16
    read0 ByteString
    t
      | Bool
    otherwise = Maybe Word16
    forall a. Maybe a
    Nothing
      where
        h :: Char
    h = ByteString -> Char
    BS.head ByteString
    bs
        t :: ByteString
    t = HasCallStack => ByteString -> ByteString
    ByteString -> ByteString
    BS.tail ByteString
    bs

    read1 :: ByteString -> Maybe Word16
    read1 :: ByteString -> Maybe Word16
    read1 ByteString
    bs
      | ByteString -> Bool
    BS.null ByteString
    bs Bool -> Bool -> Bool
    || Char
    h Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '.' Bool -> Bool -> Bool
    && ByteString -> Int
    BS.length ByteString
    t Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    4 Bool -> Bool -> Bool
    && (Char -> Bool) -> ByteString -> Bool
    BS.all (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '0') ByteString
    t =
          Word16 -> Maybe Word16
    forall a. a -> Maybe a
    Just Word16
    1000
      | Bool
    otherwise = Maybe Word16
    forall a. Maybe a
    Nothing
      where
        h :: Char
    h = ByteString -> Char
    BS.head ByteString
    bs
        t :: ByteString
    t = HasCallStack => ByteString -> ByteString
    ByteString -> ByteString
    BS.tail ByteString
    bs

    read0 :: ByteString -> Maybe Word16
    read0 :: ByteString -> Maybe Word16
    read0 ByteString
    bs
      | ByteString -> Bool
    BS.null ByteString
    bs = Word16 -> Maybe Word16
    forall a. a -> Maybe a
    Just Word16
    0
      | Char
    h Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '.' Bool -> Bool -> Bool
    && ByteString -> Int
    BS.length ByteString
    t Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    4 Bool -> Bool -> Bool
    && (Char -> Bool) -> ByteString -> Bool
    BS.all Char -> Bool
    isDigit ByteString
    t =
          Word16 -> Maybe Word16
    forall a. a -> Maybe a
    Just (ByteString -> Word16
    toWord (ByteString
    t ByteString -> ByteString -> ByteString
    forall a. Semigroup a => a -> a -> a
    <> Int -> Char -> ByteString
    BS.replicate (Int
    3 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - ByteString -> Int
    BS.length ByteString
    t) Char
    '0'))
      | Bool
    otherwise = Maybe Word16
    forall a. Maybe a
    Nothing
      where
        h :: Char
    h = ByteString -> Char
    BS.head ByteString
    bs
        t :: ByteString
    t = HasCallStack => ByteString -> ByteString
    ByteString -> ByteString
    BS.tail ByteString
    bs
        toWord :: ByteString -> Word16
    toWord = String -> Word16
    forall a. Read a => String -> a
    read (String -> Word16)
    -> (ByteString -> String) -> ByteString -> Word16
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> String
    BS.unpack