    {-# LANGUAGE CPP #-}
    {-# LANGUAGE TupleSections #-}
    {-# LANGUAGE DeriveLift #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    module Text.Collate.Lang
      ( Lang(..)
      , parseLang
      , renderLang
      , lookupLang
      )
    where
    import Data.Maybe (listToMaybe, mapMaybe)
    import Control.Monad (mzero)
    import Data.Ord (Down(..))
    import Data.List (sortOn)
    import Data.Char (isAlphaNum, isAscii, isDigit, isSpace, isAlpha)
    import Data.Text (Text)
    import qualified Data.Text as T
    import qualified Text.Parsec as P
    import Data.Binary (Binary(..))
    import Data.String
    import Language.Haskell.TH.Syntax (Lift(..))
    import Instances.TH.Lift ()
    #if MIN_VERSION_base(4,11,0)
    #else
    import Data.Semigroup (Semigroup(..))
    #endif

    -- | Represents a BCP 47 language tag (<https://tools.ietf.org/html/bcp47>).
    data Lang = Lang{ Lang -> Text
    langLanguage   :: Text
                    , Lang -> Maybe Text
    langScript     :: Maybe Text
                    , Lang -> Maybe Text
    langRegion     :: Maybe Text
                    , Lang -> [Text]
    langVariants   :: [Text]
                    , Lang -> [(Text, [(Text, Text)])]
    langExtensions :: [(Text, [(Text , Text)])]
                    , Lang -> [Text]
    langPrivateUse :: [Text]
                    } deriving (Lang -> Lang -> Bool
    (Lang -> Lang -> Bool) -> (Lang -> Lang -> Bool) -> Eq Lang
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Lang -> Lang -> Bool
    == :: Lang -> Lang -> Bool
    $c/= :: Lang -> Lang -> Bool
    /= :: Lang -> Lang -> Bool
    Eq, Eq Lang
    Eq Lang =>
    (Lang -> Lang -> Ordering)
    -> (Lang -> Lang -> Bool)
    -> (Lang -> Lang -> Bool)
    -> (Lang -> Lang -> Bool)
    -> (Lang -> Lang -> Bool)
    -> (Lang -> Lang -> Lang)
    -> (Lang -> Lang -> Lang)
    -> Ord Lang
    Lang -> Lang -> Bool
    Lang -> Lang -> Ordering
    Lang -> Lang -> Lang
    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 :: Lang -> Lang -> Ordering
    compare :: Lang -> Lang -> Ordering
    $c< :: Lang -> Lang -> Bool
    < :: Lang -> Lang -> Bool
    $c<= :: Lang -> Lang -> Bool
    <= :: Lang -> Lang -> Bool
    $c> :: Lang -> Lang -> Bool
    > :: Lang -> Lang -> Bool
    $c>= :: Lang -> Lang -> Bool
    >= :: Lang -> Lang -> Bool
    $cmax :: Lang -> Lang -> Lang
    max :: Lang -> Lang -> Lang
    $cmin :: Lang -> Lang -> Lang
    min :: Lang -> Lang -> Lang
    Ord, Int -> Lang -> ShowS
    [Lang] -> ShowS
    Lang -> String
    (Int -> Lang -> ShowS)
    -> (Lang -> String) -> ([Lang] -> ShowS) -> Show Lang
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Lang -> ShowS
    showsPrec :: Int -> Lang -> ShowS
    $cshow :: Lang -> String
    show :: Lang -> String
    $cshowList :: [Lang] -> ShowS
    showList :: [Lang] -> ShowS
    Show, (forall (m :: * -> *). Quote m => Lang -> m Exp)
    -> (forall (m :: * -> *). Quote m => Lang -> Code m Lang)
    -> Lift Lang
    forall t.
    (forall (m :: * -> *). Quote m => t -> m Exp)
    -> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
    forall (m :: * -> *). Quote m => Lang -> m Exp
    forall (m :: * -> *). Quote m => Lang -> Code m Lang
    $clift :: forall (m :: * -> *). Quote m => Lang -> m Exp
    lift :: forall (m :: * -> *). Quote m => Lang -> m Exp
    $cliftTyped :: forall (m :: * -> *). Quote m => Lang -> Code m Lang
    liftTyped :: forall (m :: * -> *). Quote m => Lang -> Code m Lang
    Lift)

    instance IsString Lang where
     fromString :: String -> Lang
    fromString =
       Lang -> Either String Lang -> Lang
    forall b a. b -> Either a b -> b
    fromRight (Text
    -> Maybe Text
    -> Maybe Text
    -> [Text]
    -> [(Text, [(Text, Text)])]
    -> [Text]
    -> Lang
    Lang Text
    "und" Maybe Text
    forall a. Maybe a
    Nothing Maybe Text
    forall a. Maybe a
    Nothing [] [] []) (Either String Lang -> Lang)
    -> (String -> Either String Lang) -> String -> Lang
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Either String Lang
    parseLang (Text -> Either String Lang)
    -> (String -> Text) -> String -> Either String Lang
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Text
    T.pack

    instance Binary Lang where
     put :: Lang -> Put
    put (Lang Text
    a Maybe Text
    b Maybe Text
    c [Text]
    d [(Text, [(Text, Text)])]
    e [Text]
    f) = (Text, Maybe Text, Maybe Text, [Text], [(Text, [(Text, Text)])],
     [Text])
    -> Put
    forall t. Binary t => t -> Put
    put (Text
    a,Maybe Text
    b,Maybe Text
    c,[Text]
    d,[(Text, [(Text, Text)])]
    e,[Text]
    f)
     get :: Get Lang
    get = do
         (a,b,c,d,e,f) <- Get
      (Text, Maybe Text, Maybe Text, [Text], [(Text, [(Text, Text)])],
       [Text])
    forall t. Binary t => Get t
    get
         return $ Lang a b c d e f

    -- | Find best match for a 'Lang' in an association list.
    lookupLang :: Lang -> [(Lang, a)] -> Maybe (Lang, a)
    lookupLang :: forall a. Lang -> [(Lang, a)] -> Maybe (Lang, a)
    lookupLang Lang
    lang =
        (((Bool, Bool, Bool, Bool), (Lang, a)) -> (Lang, a))
    -> Maybe ((Bool, Bool, Bool, Bool), (Lang, a)) -> Maybe (Lang, a)
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((Bool, Bool, Bool, Bool), (Lang, a)) -> (Lang, a)
    forall a b. (a, b) -> b
    snd
      (Maybe ((Bool, Bool, Bool, Bool), (Lang, a)) -> Maybe (Lang, a))
    -> ([(Lang, a)] -> Maybe ((Bool, Bool, Bool, Bool), (Lang, a)))
    -> [(Lang, a)]
    -> Maybe (Lang, a)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [((Bool, Bool, Bool, Bool), (Lang, a))]
    -> Maybe ((Bool, Bool, Bool, Bool), (Lang, a))
    forall a. [a] -> Maybe a
    listToMaybe
      ([((Bool, Bool, Bool, Bool), (Lang, a))]
     -> Maybe ((Bool, Bool, Bool, Bool), (Lang, a)))
    -> ([(Lang, a)] -> [((Bool, Bool, Bool, Bool), (Lang, a))])
    -> [(Lang, a)]
    -> Maybe ((Bool, Bool, Bool, Bool), (Lang, a))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (((Bool, Bool, Bool, Bool), (Lang, a))
     -> Down (Bool, Bool, Bool, Bool))
    -> [((Bool, Bool, Bool, Bool), (Lang, a))]
    -> [((Bool, Bool, Bool, Bool), (Lang, a))]
    forall b a. Ord b => (a -> b) -> [a] -> [a]
    sortOn ((Bool, Bool, Bool, Bool) -> Down (Bool, Bool, Bool, Bool)
    forall a. a -> Down a
    Down ((Bool, Bool, Bool, Bool) -> Down (Bool, Bool, Bool, Bool))
    -> (((Bool, Bool, Bool, Bool), (Lang, a))
        -> (Bool, Bool, Bool, Bool))
    -> ((Bool, Bool, Bool, Bool), (Lang, a))
    -> Down (Bool, Bool, Bool, Bool)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((Bool, Bool, Bool, Bool), (Lang, a)) -> (Bool, Bool, Bool, Bool)
    forall a b. (a, b) -> a
    fst)
      ([((Bool, Bool, Bool, Bool), (Lang, a))]
     -> [((Bool, Bool, Bool, Bool), (Lang, a))])
    -> ([(Lang, a)] -> [((Bool, Bool, Bool, Bool), (Lang, a))])
    -> [(Lang, a)]
    -> [((Bool, Bool, Bool, Bool), (Lang, a))]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((Lang, a) -> Maybe ((Bool, Bool, Bool, Bool), (Lang, a)))
    -> [(Lang, a)] -> [((Bool, Bool, Bool, Bool), (Lang, a))]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe (\(Lang
    l,a
    t) ->
           case Lang -> Maybe (Bool, Bool, Bool, Bool)
    match Lang
    l of
             Maybe (Bool, Bool, Bool, Bool)
    Nothing -> Maybe ((Bool, Bool, Bool, Bool), (Lang, a))
    forall a. Maybe a
    Nothing
             Just (Bool, Bool, Bool, Bool)
    x -> ((Bool, Bool, Bool, Bool), (Lang, a))
    -> Maybe ((Bool, Bool, Bool, Bool), (Lang, a))
    forall a. a -> Maybe a
    Just ((Bool, Bool, Bool, Bool)
    x,(Lang
    l,a
    t)))
     where
      langsMatch :: Lang -> Maybe Bool
    langsMatch Lang
    l = if Lang -> Text
    langLanguage Lang
    lang Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Lang -> Text
    langLanguage Lang
    l
                        then Bool -> Maybe Bool
    forall a. a -> Maybe a
    Just Bool
    True
                        else Maybe Bool
    forall a. Maybe a
    Nothing
      maybeMatch :: (Lang -> Maybe a) -> Lang -> Maybe Bool
    maybeMatch Lang -> Maybe a
    f Lang
    l = case (Lang -> Maybe a
    f Lang
    l, Lang -> Maybe a
    f Lang
    lang) of
                         (Maybe a
    Nothing, Maybe a
    Nothing) -> Bool -> Maybe Bool
    forall a. a -> Maybe a
    Just Bool
    True
                         (Maybe a
    Nothing, Just a
    _)  -> Bool -> Maybe Bool
    forall a. a -> Maybe a
    Just Bool
    False
                         (Just a
    x, Maybe a
    mby)      -> case Maybe a
    mby of
                                                 Just a
    y | a
    x a -> a -> Bool
    forall a. Eq a => a -> a -> Bool
    == a
    y -> Bool -> Maybe Bool
    forall a. a -> Maybe a
    Just Bool
    True
                                                 Maybe a
    _ -> Maybe Bool
    forall a. Maybe a
    Nothing
      langCollation :: Lang -> Maybe Text
    langCollation Lang
    l = Text -> [(Text, [(Text, Text)])] -> Maybe [(Text, Text)]
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Text
    "u" (Lang -> [(Text, [(Text, Text)])]
    langExtensions Lang
    l) Maybe [(Text, Text)]
    -> ([(Text, Text)] -> Maybe Text) -> Maybe Text
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Text -> [(Text, Text)] -> Maybe Text
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Text
    "co"
      match :: Lang -> Maybe (Bool, Bool, Bool, Bool)
    match Lang
    l = do
        lm <- Lang -> Maybe Bool
    langsMatch Lang
    l
        sm <- maybeMatch langScript l
        rm <- maybeMatch langRegion l
        cm <- maybeMatch langCollation l
        return (lm,sm,rm,cm)

    -- | Render a 'Lang' in BCP 47 form.
    renderLang :: Lang -> Text
    renderLang :: Lang -> Text
    renderLang Lang
    lang =
        Lang -> Text
    langLanguage Lang
    lang
         Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> (Text -> Text) -> Maybe Text -> Text
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Text
    "" (Char -> Text -> Text
    T.cons Char
    '-') (Lang -> Maybe Text
    langScript Lang
    lang)
         Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> (Text -> Text) -> Maybe Text -> Text
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Text
    "" (Char -> Text -> Text
    T.cons Char
    '-') (Lang -> Maybe Text
    langRegion Lang
    lang)
         Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> [Text] -> Text
    forall a. Monoid a => [a] -> a
    mconcat ((Text -> Text) -> [Text] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map (Char -> Text -> Text
    T.cons Char
    '-') (Lang -> [Text]
    langVariants Lang
    lang))
         Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> [Text] -> Text
    forall a. Monoid a => [a] -> a
    mconcat (((Text, [(Text, Text)]) -> Text)
    -> [(Text, [(Text, Text)])] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map (Text, [(Text, Text)]) -> Text
    renderExtension (Lang -> [(Text, [(Text, Text)])]
    langExtensions Lang
    lang))
         Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> [Text] -> Text
    renderPrivateUse (Lang -> [Text]
    langPrivateUse Lang
    lang)
     where
      renderExtension :: (Text, [(Text, Text)]) -> Text
    renderExtension (Text
    c, [(Text, Text)]
    ks) = Text
    "-" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    c Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> [Text] -> Text
    forall a. Monoid a => [a] -> a
    mconcat (((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map (Text, Text) -> Text
    renderKeyword [(Text, Text)]
    ks)
      renderKeyword :: (Text, Text) -> Text
    renderKeyword (Text
    k, Text
    v) = Text
    "-" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    k Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> if Text -> Bool
    T.null Text
    v
                                            then Text
    ""
                                            else Text
    "-" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    v
      renderPrivateUse :: [Text] -> Text
    renderPrivateUse [] = Text
    ""
      renderPrivateUse [Text]
    ts = Text
    "-x" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> [Text] -> Text
    forall a. Monoid a => [a] -> a
    mconcat ((Text -> Text) -> [Text] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map (Char -> Text -> Text
    T.cons Char
    '-') [Text]
    ts)

    -- | Parse a BCP 47 language tag as a 'Lang'.
    parseLang :: Text -> Either String Lang
    parseLang :: Text -> Either String Lang
    parseLang Text
    lang =
      case Parsec [Text] () Lang -> String -> [Text] -> Either ParseError Lang
    forall s t a.
    Stream s Identity t =>
    Parsec s () a -> String -> s -> Either ParseError a
    P.parse Parsec [Text] () Lang
    pLangTag String
    "lang" ((Char -> Bool) -> Text -> [Text]
    T.split (\Char
    c -> Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '-' Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '_')
                                     (Text -> [Text]) -> Text -> [Text]
    forall a b. (a -> b) -> a -> b
    $ (Char -> Bool) -> Text -> Text
    T.takeWhile (Bool -> Bool
    not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> Bool
    isSpace) Text
    lang) of
           Right Lang
    r -> Lang -> Either String Lang
    forall a b. b -> Either a b
    Right Lang
    r
           Left ParseError
    e  -> String -> Either String Lang
    forall a b. a -> Either a b
    Left (String -> Either String Lang) -> String -> Either String Lang
    forall a b. (a -> b) -> a -> b
    $ ParseError -> String
    forall a. Show a => a -> String
    show ParseError
    e
      where
        -- langtag       = language
        --                ["-" script]
        --                ["-" region]
        --                 *("-" variant)
        --                 *("-" extension)
        pLangTag :: Parsec [Text] () Lang
    pLangTag = do
          language <- ParsecT [Text] () Identity Text
    pLanguage ParsecT [Text] () Identity Text
    -> String -> ParsecT [Text] () Identity Text
    forall s u (m :: * -> *) a.
    ParsecT s u m a -> String -> ParsecT s u m a
    P.<?> String
    "language"
          script <- P.option Nothing (Just <$> pScript P.<?> "script")
          region <- P.option Nothing (Just <$> pRegion P.<?> "region")
          variants <- P.many pVariant P.<?> "variant"
          extensions <- P.many pExtension P.<?> "extension"
          privateUse <- P.option [] (pPrivateUse P.<?> "private use")
          -- P.eof  -- like CSL, we allow garbage afterwards
          return Lang{   langLanguage = language
                       , langScript = script
                       , langRegion = region
                       , langVariants = variants
                       , langExtensions = extensions
                       , langPrivateUse = privateUse }

        -- language      = 2*3ALPHA            ; shortest ISO 639 code
        --                 ["-" extlang]       ; sometimes followed by
        --                                     ; extended language subtags
        --               / 4ALPHA              ; or reserved for future use
        --               / 5*8ALPHA            ; or registered language subtag
        pLanguage :: ParsecT [Text] () Identity Text
    pLanguage = (do
          baselang <- Text -> Text
    T.toLower (Text -> Text)
    -> ParsecT [Text] () Identity Text
    -> ParsecT [Text] () Identity Text
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Int -> Int -> ParsecT [Text] () Identity Text
    alphasBetween Int
    2 Int
    3
          extlang <- P.option Nothing $ Just <$> pExtlang
          case extlang of
            Maybe Text
    Nothing  -> Text -> ParsecT [Text] () Identity Text
    forall a. a -> ParsecT [Text] () Identity a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Text
    baselang
            Just Text
    ext -> Text -> ParsecT [Text] () Identity Text
    forall a. a -> ParsecT [Text] () Identity a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Text -> ParsecT [Text] () Identity Text)
    -> Text -> ParsecT [Text] () Identity Text
    forall a b. (a -> b) -> a -> b
    $ Text
    baselang Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "-" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    ext)
          ParsecT [Text] () Identity Text
    -> ParsecT [Text] () Identity Text
    -> ParsecT [Text] () Identity Text
    forall s u (m :: * -> *) a.
    ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
    P.<|> Text -> Text
    T.toLower (Text -> Text)
    -> ParsecT [Text] () Identity Text
    -> ParsecT [Text] () Identity Text
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Int -> Int -> ParsecT [Text] () Identity Text
    alphasBetween Int
    4 Int
    8

        -- extlang       = 3ALPHA              ; selected ISO 639 codes
        --                 *2("-" 3ALPHA)      ; permanently reserved
        pExtlang :: ParsecT [Text] () Identity Text
    pExtlang = Text -> [Text] -> Text
    T.intercalate Text
    "-" ([Text] -> Text)
    -> ParsecT [Text] () Identity [Text]
    -> ParsecT [Text] () Identity Text
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Int
    -> Int
    -> ParsecT [Text] () Identity Text
    -> ParsecT [Text] () Identity [Text]
    forall {s} {u} {m :: * -> *} {a}.
    Int -> Int -> ParsecT s u m a -> ParsecT s u m [a]
    countBetween Int
    1 Int
    3
                     (Text -> Text
    T.toLower (Text -> Text)
    -> ParsecT [Text] () Identity Text
    -> ParsecT [Text] () Identity Text
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Int -> ParsecT [Text] () Identity Text
    alphas Int
    3)

        -- script        = 4ALPHA              ; ISO 15924 code
        pScript :: ParsecT [Text] () Identity Text
    pScript = Text -> Text
    T.toTitle (Text -> Text)
    -> ParsecT [Text] () Identity Text
    -> ParsecT [Text] () Identity Text
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Int -> ParsecT [Text] () Identity Text
    alphas Int
    4

        -- region        = 2ALPHA              ; ISO 3166-1 code
        --               / 3DIGIT              ; UN M.49 code
        pRegion :: ParsecT [Text] () Identity Text
    pRegion = Text -> Text
    T.toUpper (Text -> Text)
    -> ParsecT [Text] () Identity Text
    -> ParsecT [Text] () Identity Text
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Int -> ParsecT [Text] () Identity Text
    alphas Int
    2 ParsecT [Text] () Identity Text
    -> ParsecT [Text] () Identity Text
    -> ParsecT [Text] () Identity Text
    forall s u (m :: * -> *) a.
    ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
    P.<|> Int -> ParsecT [Text] () Identity Text
    digits Int
    3

        -- variant       = 5*8alphanum         ; registered variants
        --              / (DIGIT 3alphanum)
        pVariant :: ParsecT [Text] () Identity Text
    pVariant = Text -> Text
    T.toLower (Text -> Text)
    -> ParsecT [Text] () Identity Text
    -> ParsecT [Text] () Identity Text
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$>
          (Int -> Int -> ParsecT [Text] () Identity Text
    alphanumsBetween Int
    5 Int
    8
           ParsecT [Text] () Identity Text
    -> ParsecT [Text] () Identity Text
    -> ParsecT [Text] () Identity Text
    forall s u (m :: * -> *) a.
    ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
    P.<|> (Text -> Bool) -> ParsecT [Text] () Identity Text
    tok (\Text
    t -> (Char -> Bool) -> Text -> Bool
    T.all Char -> Bool
    isAsciiAlphaNum Text
    t Bool -> Bool -> Bool
    && Text -> Int
    T.length Text
    t Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    4 Bool -> Bool -> Bool
    &&
                                        Char -> Bool
    isDigit (HasCallStack => Text -> Char
    Text -> Char
    T.head Text
    t)))

        -- extension     = singleton 1*("-" (2*8alphanum))
        -- RFC6087:
        -- An 'attribute' is a subtag with a length of three to eight
        -- characters following the singleton and preceding any 'keyword'
        -- sequences.  No attributes were defined at the time of this
        -- document's publication.

        -- A 'keyword' is a sequence of subtags consisting of a 'key' subtag,
        -- followed by zero or more 'type' subtags (so a 'key' might appear
        -- alone and not be accompanied by a 'type' subtag).  A 'key' MUST
        -- NOT appear more than once in a language tag's extension string.
        -- The order of the 'type' subtags within a 'keyword' is sometimes
        -- significant to their interpretation.

        -- A.  A 'key' is a subtag with a length of exactly two characters.
        --     Each 'key' is followed by zero or more 'type' subtags.

        -- B.  A 'type' is a subtag with a length of three to eight
        --     characters following a 'key'.  'Type' subtags are specific to
        --     a particular 'key' and the order of the 'type' subtags MAY be
        --     significant to the interpretation of the 'keyword'.
        pExtension :: ParsecT [Text] () Identity (Text, [(Text, Text)])
    pExtension = do
          c <- Text -> Text
    T.toLower (Text -> Text)
    -> ParsecT [Text] () Identity Text
    -> ParsecT [Text] () Identity Text
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Text -> Bool) -> ParsecT [Text] () Identity Text
    tok (\Text
    t -> Text -> Int
    T.length Text
    t Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    1 Bool -> Bool -> Bool
    && (Char -> Bool) -> Text -> Bool
    T.all Char -> Bool
    isAsciiAlphaNum Text
    t)
          attrs <- P.many
                 (T.toLower <$>
                   tok (\Text
    t -> (Char -> Bool) -> Text -> Bool
    T.all Char -> Bool
    isAsciiAlphaNum Text
    t Bool -> Bool -> Bool
    && Int -> Int -> Text -> Bool
    lengthBetween Int
    3 Int
    8 Text
    t))
          keywords <- P.many pKeyword
          return (c, map (, "") attrs ++ keywords)

        pKeyword :: ParsecT [Text] () Identity (Text, Text)
    pKeyword = do
          key <- Int -> ParsecT [Text] () Identity Text
    alphas Int
    2
          types <- P.many (alphanumsBetween 3 8)
          return (key, T.intercalate "-" types)

        -- privateuse    = "x" 1*("-" (1*8alphanum))
        pPrivateUse :: ParsecT [Text] () Identity [Text]
    pPrivateUse = do
          _ <- (Text -> Bool) -> ParsecT [Text] () Identity Text
    tok (\Text
    t -> Text -> Text
    T.toLower Text
    t Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "x")
          P.many1 (alphanumsBetween 1 8)

        tok :: (Text -> Bool) -> P.Parsec [Text] () Text
        tok :: (Text -> Bool) -> ParsecT [Text] () Identity Text
    tok Text -> Bool
    f = (Text -> String)
    -> (SourcePos -> Text -> [Text] -> SourcePos)
    -> (Text -> Maybe Text)
    -> ParsecT [Text] () Identity Text
    forall s (m :: * -> *) t a u.
    Stream s m t =>
    (t -> String)
    -> (SourcePos -> t -> s -> SourcePos)
    -> (t -> Maybe a)
    -> ParsecT s u m a
    P.tokenPrim Text -> String
    T.unpack (\SourcePos
    pos Text
    t [Text]
    _ ->
                                       SourcePos -> Int -> SourcePos
    P.incSourceColumn SourcePos
    pos (Text -> Int
    T.length Text
    t))
                          (\Text
    t -> if Text -> Bool
    f Text
    t then Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    t else Maybe Text
    forall a. Maybe a
    Nothing)

        countBetween :: Int -> Int -> ParsecT s u m a -> ParsecT s u m [a]
    countBetween (Int
    low :: Int) (Int
    hi :: Int) ParsecT s u m a
    p = ParsecT s u m [a] -> ParsecT s u m [a]
    forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
    P.try (ParsecT s u m [a] -> ParsecT s u m [a])
    -> ParsecT s u m [a] -> ParsecT s u m [a]
    forall a b. (a -> b) -> a -> b
    $ Int -> Int -> ParsecT s u m a -> Int -> ParsecT s u m [a]
    forall {s} {u} {m :: * -> *} {a}.
    Int -> Int -> ParsecT s u m a -> Int -> ParsecT s u m [a]
    countBetween' Int
    low Int
    hi ParsecT s u m a
    p Int
    1
        countBetween' :: Int -> Int -> ParsecT s u m a -> Int -> ParsecT s u m [a]
    countBetween' Int
    low Int
    hi ParsecT s u m a
    p (Int
    n :: Int) = (do
         res <- ParsecT s u m a
    p
         if n >= hi
            then return [res]
            else (res:) <$> countBetween' low hi p (n + 1))
          ParsecT s u m [a] -> ParsecT s u m [a] -> ParsecT s u m [a]
    forall s u (m :: * -> *) a.
    ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
    P.<|> (if Int
    n Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    low then [a] -> ParsecT s u m [a]
    forall a. a -> ParsecT s u m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [] else ParsecT s u m [a]
    forall a. ParsecT s u m a
    forall (m :: * -> *) a. MonadPlus m => m a
    mzero)

        isAsciiAlpha :: Char -> Bool
    isAsciiAlpha Char
    c = Char -> Bool
    isAscii Char
    c Bool -> Bool -> Bool
    && Char -> Bool
    isAlpha Char
    c
        alphas :: Int -> ParsecT [Text] () Identity Text
    alphas Int
    len = (Text -> Bool) -> ParsecT [Text] () Identity Text
    tok (\Text
    t -> (Char -> Bool) -> Text -> Bool
    T.all Char -> Bool
    isAsciiAlpha Text
    t Bool -> Bool -> Bool
    && Text -> Int
    T.length Text
    t Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    len)
        digits :: Int -> ParsecT [Text] () Identity Text
    digits Int
    len = (Text -> Bool) -> ParsecT [Text] () Identity Text
    tok (\Text
    t -> (Char -> Bool) -> Text -> Bool
    T.all Char -> Bool
    isDigit Text
    t Bool -> Bool -> Bool
    && Text -> Int
    T.length Text
    t Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    len)
        alphasBetween :: Int -> Int -> ParsecT [Text] () Identity Text
    alphasBetween Int
    minLen Int
    maxLen =
          (Text -> Bool) -> ParsecT [Text] () Identity Text
    tok (\Text
    t -> (Char -> Bool) -> Text -> Bool
    T.all Char -> Bool
    isAsciiAlpha Text
    t Bool -> Bool -> Bool
    && Int -> Int -> Text -> Bool
    lengthBetween Int
    minLen Int
    maxLen Text
    t)
        alphanumsBetween :: Int -> Int -> ParsecT [Text] () Identity Text
    alphanumsBetween Int
    minLen Int
    maxLen =
          (Text -> Bool) -> ParsecT [Text] () Identity Text
    tok (\Text
    t -> (Char -> Bool) -> Text -> Bool
    T.all Char -> Bool
    isAsciiAlphaNum Text
    t Bool -> Bool -> Bool
    && Int -> Int -> Text -> Bool
    lengthBetween Int
    minLen Int
    maxLen Text
    t)
        lengthBetween :: Int -> Int -> Text -> Bool
    lengthBetween Int
    lo Int
    hi Text
    t = let len :: Int
    len = Text -> Int
    T.length Text
    t in Int
    len Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    lo Bool -> Bool -> Bool
    && Int
    len Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    hi
        isAsciiAlphaNum :: Char -> Bool
    isAsciiAlphaNum Char
    c = Char -> Bool
    isAscii Char
    c Bool -> Bool -> Bool
    && Char -> Bool
    isAlphaNum Char
    c

    -- We define fromRight here instead of importing it,
    -- because it doesn't exist in some base versions we support.
    fromRight :: b -> Either a b -> b
    fromRight :: forall b a. b -> Either a b -> b
    fromRight b
    fallback (Left a
    _)  = b
    fallback
    fromRight b
    _        (Right b
    x) = b
    x