    -- | Defines the 'Language' accept header with an 'Accept' instance for use in
    -- language negotiation.
    module Network.HTTP.Media.Language.Internal
      ( Language (..),
      )
    where

    import Control.Monad (guard)
    import Data.ByteString (ByteString)
    import qualified Data.ByteString.Char8 as BS
    import Data.CaseInsensitive (CI, original)
    import qualified Data.CaseInsensitive as CI
    import Data.Char (isAlpha, isAlphaNum)
    import Data.List (isPrefixOf)
    import Data.Maybe (fromMaybe)
    import Data.String (IsString (..))
    import Network.HTTP.Media.Accept (Accept (..))
    import Network.HTTP.Media.RenderHeader (RenderHeader (..))

    -- | Suitable for HTTP language-ranges as defined in
    -- <https://tools.ietf.org/html/rfc4647#section-2.1 RFC4647>.
    --
    -- Specifically:
    --
    -- > language-range = (1*8ALPHA *("-" 1*8alphanum)) / "*"
    newtype Language = Language [CI ByteString]
      deriving (Language -> Language -> Bool
    (Language -> Language -> Bool)
    -> (Language -> Language -> Bool) -> Eq Language
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Language -> Language -> Bool
    == :: Language -> Language -> Bool
    $c/= :: Language -> Language -> Bool
    /= :: Language -> Language -> Bool
    Eq, Eq Language
    Eq Language =>
    (Language -> Language -> Ordering)
    -> (Language -> Language -> Bool)
    -> (Language -> Language -> Bool)
    -> (Language -> Language -> Bool)
    -> (Language -> Language -> Bool)
    -> (Language -> Language -> Language)
    -> (Language -> Language -> Language)
    -> Ord Language
    Language -> Language -> Bool
    Language -> Language -> Ordering
    Language -> Language -> Language
    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 :: Language -> Language -> Ordering
    compare :: Language -> Language -> Ordering
    $c< :: Language -> Language -> Bool
    < :: Language -> Language -> Bool
    $c<= :: Language -> Language -> Bool
    <= :: Language -> Language -> Bool
    $c> :: Language -> Language -> Bool
    > :: Language -> Language -> Bool
    $c>= :: Language -> Language -> Bool
    >= :: Language -> Language -> Bool
    $cmax :: Language -> Language -> Language
    max :: Language -> Language -> Language
    $cmin :: Language -> Language -> Language
    min :: Language -> Language -> Language
    Ord)

    -- Note that internally, Language [] equates to *.

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

    instance IsString Language where
      fromString :: String -> Language
    fromString String
    "*" = [CI ByteString] -> Language
    Language []
      fromString String
    str =
        (Language -> Maybe Language -> Language)
    -> Maybe Language -> Language -> Language
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Language -> Maybe Language -> Language
    forall a. a -> Maybe a -> a
    fromMaybe (ByteString -> Maybe Language
    forall a. Accept a => ByteString -> Maybe a
    parseAccept (ByteString -> Maybe Language) -> ByteString -> Maybe Language
    forall a b. (a -> b) -> a -> b
    $ String -> ByteString
    BS.pack String
    str) (Language -> Language) -> Language -> Language
    forall a b. (a -> b) -> a -> b
    $
          String -> Language
    forall a. HasCallStack => String -> a
    error (String -> Language) -> String -> Language
    forall a b. (a -> b) -> a -> b
    $
            String
    "Invalid language literal " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    str

    instance Accept Language where
      parseAccept :: ByteString -> Maybe Language
    parseAccept ByteString
    "*" = Language -> Maybe Language
    forall a. a -> Maybe a
    Just (Language -> Maybe Language) -> Language -> Maybe Language
    forall a b. (a -> b) -> a -> b
    $ [CI ByteString] -> Language
    Language []
      parseAccept ByteString
    bs = do
        let pieces :: [ByteString]
    pieces = Char -> ByteString -> [ByteString]
    BS.split Char
    '-' ByteString
    bs
        Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Bool -> Maybe ()) -> Bool -> Maybe ()
    forall a b. (a -> b) -> a -> b
    $ Bool -> Bool
    not ([ByteString] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [ByteString]
    pieces)
        [CI ByteString] -> Language
    Language ([CI ByteString] -> Language)
    -> Maybe [CI ByteString] -> Maybe Language
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (ByteString -> Maybe (CI ByteString))
    -> [ByteString] -> Maybe [CI ByteString]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM ByteString -> Maybe (CI ByteString)
    forall {m :: * -> *}.
    (Monad m, Alternative m) =>
    ByteString -> m (CI ByteString)
    check [ByteString]
    pieces
        where
          check :: ByteString -> m (CI ByteString)
    check ByteString
    part = do
            let len :: Int
    len = ByteString -> Int
    BS.length ByteString
    part
            Bool -> m ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Bool -> m ()) -> Bool -> m ()
    forall a b. (a -> b) -> a -> b
    $
              Int
    len Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    1
                Bool -> Bool -> Bool
    && Int
    len Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    8
                Bool -> Bool -> Bool
    && Char -> Bool
    isAlpha (ByteString -> Char
    BS.head ByteString
    part)
                Bool -> Bool -> Bool
    && (Char -> Bool) -> ByteString -> Bool
    BS.all Char -> Bool
    isAlphaNum (HasCallStack => ByteString -> ByteString
    ByteString -> ByteString
    BS.tail ByteString
    part)
            CI ByteString -> m (CI ByteString)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ByteString -> CI ByteString
    forall s. FoldCase s => s -> CI s
    CI.mk ByteString
    part)

      -- Languages match if the right argument is a prefix of the left.
      matches :: Language -> Language -> Bool
    matches (Language [CI ByteString]
    a) (Language [CI ByteString]
    b) = [CI ByteString]
    b [CI ByteString] -> [CI ByteString] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` [CI ByteString]
    a

      -- The left language is more specific than the right if the right
      -- arguments is a strict prefix of the left.
      moreSpecificThan :: Language -> Language -> Bool
    moreSpecificThan (Language [CI ByteString]
    a) (Language [CI ByteString]
    b) =
        [CI ByteString]
    b [CI ByteString] -> [CI ByteString] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` [CI ByteString]
    a Bool -> Bool -> Bool
    && [CI ByteString] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [CI ByteString]
    a Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > [CI ByteString] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [CI ByteString]
    b

    instance RenderHeader Language where
      renderHeader :: Language -> ByteString
    renderHeader (Language []) = ByteString
    "*"
      renderHeader (Language [CI ByteString]
    l) = ByteString -> [ByteString] -> ByteString
    BS.intercalate ByteString
    "-" ((CI ByteString -> ByteString) -> [CI ByteString] -> [ByteString]
    forall a b. (a -> b) -> [a] -> [b]
    map CI ByteString -> ByteString
    forall s. CI s -> s
    original [CI ByteString]
    l)