{-# 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
/= :: Lang -> Lang -> Bool
$c/= :: Lang -> Lang -> Bool
== :: Lang -> Lang -> Bool
$c== :: 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
min :: Lang -> Lang -> Lang
$cmin :: Lang -> Lang -> Lang
max :: Lang -> Lang -> Lang
$cmax :: Lang -> Lang -> Lang
>= :: Lang -> Lang -> Bool
$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
compare :: Lang -> Lang -> Ordering
$ccompare :: Lang -> Lang -> Ordering
$cp1Ord :: Eq 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
showList :: [Lang] -> ShowS
$cshowList :: [Lang] -> ShowS
show :: Lang -> String
$cshow :: Lang -> String
showsPrec :: Int -> Lang -> ShowS
$cshowsPrec :: Int -> Lang -> ShowS
Show, Lang -> Q Exp
(Lang -> Q Exp) -> Lift Lang
forall t. (t -> Q Exp) -> Lift t
lift :: Lang -> Q Exp
$clift :: Lang -> Q Exp
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 "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 a :: Text
a b :: Maybe Text
b c :: Maybe Text
c d :: [Text]
d e :: [(Text, [(Text, Text)])]
e f :: [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 :: Text
a,b :: Maybe Text
b,c :: Maybe Text
c,d :: [Text]
d,e :: [(Text, [(Text, Text)])]
e,f :: [Text]
f) <- Get
  (Text, Maybe Text, Maybe Text, [Text], [(Text, [(Text, Text)])],
   [Text])
forall t. Binary t => Get t
get
     Lang -> Get Lang
forall (m :: * -> *) a. Monad m => a -> m a
return (Lang -> Get Lang) -> Lang -> Get Lang
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Text
-> Maybe Text
-> [Text]
-> [(Text, [(Text, Text)])]
-> [Text]
-> Lang
Lang Text
a Maybe Text
b Maybe Text
c [Text]
d [(Text, [(Text, Text)])]
e [Text]
f

-- | Find best match for a 'Lang' in an association list.
lookupLang :: Lang -> [(Lang, a)] -> Maybe (Lang, a)
lookupLang :: Lang -> [(Lang, a)] -> Maybe (Lang, a)
lookupLang lang :: Lang
lang =
    (((Bool, Bool, Bool, Bool), (Lang, a)) -> (Lang, a))
-> Maybe ((Bool, Bool, Bool, Bool), (Lang, a)) -> Maybe (Lang, a)
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 (\(l :: Lang
l,t :: a
t) ->
       case Lang -> Maybe (Bool, Bool, Bool, Bool)
match Lang
l of
         Nothing -> Maybe ((Bool, Bool, Bool, Bool), (Lang, a))
forall a. Maybe a
Nothing
         Just x :: (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 l :: 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 f :: Lang -> Maybe a
f l :: Lang
l = case (Lang -> Maybe a
f Lang
l, Lang -> Maybe a
f Lang
lang) of
                     (Nothing, Nothing) -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
                     (Nothing, Just _)  -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
                     (Just x :: a
x, mby :: Maybe a
mby)      -> case Maybe a
mby of
                                             Just y :: 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 Bool
forall a. Maybe a
Nothing
  langCollation :: Lang -> Maybe Text
langCollation l :: Lang
l = Text -> [(Text, [(Text, Text)])] -> Maybe [(Text, Text)]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "u" (Lang -> [(Text, [(Text, Text)])]
langExtensions Lang
l) Maybe [(Text, Text)]
-> ([(Text, Text)] -> Maybe Text) -> Maybe Text
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 "co"
  match :: Lang -> Maybe (Bool, Bool, Bool, Bool)
match l :: Lang
l = do
    Bool
lm <- Lang -> Maybe Bool
langsMatch Lang
l
    Bool
sm <- (Lang -> Maybe Text) -> Lang -> Maybe Bool
forall a. Eq a => (Lang -> Maybe a) -> Lang -> Maybe Bool
maybeMatch Lang -> Maybe Text
langScript Lang
l
    Bool
rm <- (Lang -> Maybe Text) -> Lang -> Maybe Bool
forall a. Eq a => (Lang -> Maybe a) -> Lang -> Maybe Bool
maybeMatch Lang -> Maybe Text
langRegion Lang
l
    Bool
cm <- (Lang -> Maybe Text) -> Lang -> Maybe Bool
forall a. Eq a => (Lang -> Maybe a) -> Lang -> Maybe Bool
maybeMatch Lang -> Maybe Text
langCollation Lang
l
    (Bool, Bool, Bool, Bool) -> Maybe (Bool, Bool, Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
lm,Bool
sm,Bool
rm,Bool
cm)

-- | Render a 'Lang' in BCP 47 form.
renderLang :: Lang -> Text
renderLang :: Lang -> Text
renderLang lang :: 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 "" (Char -> Text -> Text
T.cons '-') (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 "" (Char -> Text -> Text
T.cons '-') (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 '-') (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 (c :: Text
c, ks :: [(Text, Text)]
ks) = "-" 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 (k :: Text
k, v :: Text
v) = "-" 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 ""
                                        else "-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v
  renderPrivateUse :: [Text] -> Text
renderPrivateUse [] = ""
  renderPrivateUse ts :: [Text]
ts = "-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 '-') [Text]
ts)

-- | Parse a BCP 47 language tag as a 'Lang'.
parseLang :: Text -> Either String Lang
parseLang :: Text -> Either String Lang
parseLang lang :: 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 "lang" ((Char -> Bool) -> Text -> [Text]
T.split (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_')
                                 (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 r :: Lang
r -> Lang -> Either String Lang
forall a b. b -> Either a b
Right Lang
r
       Left e :: 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
      Text
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.<?> "language"
      Maybe Text
script <- Maybe Text
-> ParsecT [Text] () Identity (Maybe Text)
-> ParsecT [Text] () Identity (Maybe Text)
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
P.option Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> ParsecT [Text] () Identity Text
-> ParsecT [Text] () Identity (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Text] () Identity Text
pScript ParsecT [Text] () Identity (Maybe Text)
-> String -> ParsecT [Text] () Identity (Maybe Text)
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
P.<?> "script")
      Maybe Text
region <- Maybe Text
-> ParsecT [Text] () Identity (Maybe Text)
-> ParsecT [Text] () Identity (Maybe Text)
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
P.option Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> ParsecT [Text] () Identity Text
-> ParsecT [Text] () Identity (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Text] () Identity Text
pRegion ParsecT [Text] () Identity (Maybe Text)
-> String -> ParsecT [Text] () Identity (Maybe Text)
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
P.<?> "region")
      [Text]
variants <- ParsecT [Text] () Identity Text
-> ParsecT [Text] () Identity [Text]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
P.many ParsecT [Text] () Identity Text
pVariant 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.<?> "variant"
      [(Text, [(Text, Text)])]
extensions <- ParsecT [Text] () Identity (Text, [(Text, Text)])
-> ParsecT [Text] () Identity [(Text, [(Text, Text)])]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
P.many ParsecT [Text] () Identity (Text, [(Text, Text)])
pExtension ParsecT [Text] () Identity [(Text, [(Text, Text)])]
-> String -> ParsecT [Text] () Identity [(Text, [(Text, Text)])]
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
P.<?> "extension"
      [Text]
privateUse <- [Text]
-> ParsecT [Text] () Identity [Text]
-> ParsecT [Text] () Identity [Text]
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
P.option [] (ParsecT [Text] () Identity [Text]
pPrivateUse 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.<?> "private use")
      -- P.eof  -- like CSL, we allow garbage afterwards
      Lang -> Parsec [Text] () Lang
forall (m :: * -> *) a. Monad m => a -> m a
return Lang :: Text
-> Maybe Text
-> Maybe Text
-> [Text]
-> [(Text, [(Text, Text)])]
-> [Text]
-> Lang
Lang{   langLanguage :: Text
langLanguage = Text
language
                   , langScript :: Maybe Text
langScript = Maybe Text
script
                   , langRegion :: Maybe Text
langRegion = Maybe Text
region
                   , langVariants :: [Text]
langVariants = [Text]
variants
                   , langExtensions :: [(Text, [(Text, Text)])]
langExtensions = [(Text, [(Text, Text)])]
extensions
                   , langPrivateUse :: [Text]
langPrivateUse = [Text]
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
      Text
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 2 3
      Maybe Text
extlang <- Maybe Text
-> ParsecT [Text] () Identity (Maybe Text)
-> ParsecT [Text] () Identity (Maybe Text)
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
P.option Maybe Text
forall a. Maybe a
Nothing (ParsecT [Text] () Identity (Maybe Text)
 -> ParsecT [Text] () Identity (Maybe Text))
-> ParsecT [Text] () Identity (Maybe Text)
-> ParsecT [Text] () Identity (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> ParsecT [Text] () Identity Text
-> ParsecT [Text] () Identity (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Text] () Identity Text
pExtlang
      case Maybe Text
extlang of
        Nothing  -> Text -> ParsecT [Text] () Identity Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
baselang
        Just ext :: Text
ext -> Text -> ParsecT [Text] () Identity Text
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
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 4 8

    -- extlang       = 3ALPHA              ; selected ISO 639 codes
    --                 *2("-" 3ALPHA)      ; permanently reserved
    pExtlang :: ParsecT [Text] () Identity Text
pExtlang = Text -> [Text] -> Text
T.intercalate "-" ([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 1 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 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 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 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 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 5 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 (\t :: 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
== 4 Bool -> Bool -> Bool
&&
                                    Char -> Bool
isDigit (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
      Text
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 (\t :: Text
t -> Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isAsciiAlphaNum Text
t)
      [Text]
attrs <- ParsecT [Text] () Identity Text
-> ParsecT [Text] () Identity [Text]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
P.many
             (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 (\t :: Text
t -> (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isAsciiAlphaNum Text
t Bool -> Bool -> Bool
&& Int -> Int -> Text -> Bool
lengthBetween 3 8 Text
t))
      [(Text, Text)]
keywords <- ParsecT [Text] () Identity (Text, Text)
-> ParsecT [Text] () Identity [(Text, Text)]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
P.many ParsecT [Text] () Identity (Text, Text)
pKeyword
      (Text, [(Text, Text)])
-> ParsecT [Text] () Identity (Text, [(Text, Text)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
c, (Text -> (Text, Text)) -> [Text] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (, "") [Text]
attrs [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ [(Text, Text)]
keywords)

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

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

    tok :: (Text -> Bool) -> P.Parsec [Text] () Text
    tok :: (Text -> Bool) -> ParsecT [Text] () Identity Text
tok f :: 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 (\pos :: SourcePos
pos t :: Text
t _ ->
                                   SourcePos -> Int -> SourcePos
P.incSourceColumn SourcePos
pos (Text -> Int
T.length Text
t))
                      (\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) p :: 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 1
    countBetween' :: Int -> Int -> ParsecT s u m a -> Int -> ParsecT s u m [a]
countBetween' low :: Int
low hi :: Int
hi p :: ParsecT s u m a
p (Int
n :: Int) = (do
     a
res <- ParsecT s u m a
p
     if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
hi
        then [a] -> ParsecT s u m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a
res]
        else (a
resa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> ParsecT s u m [a] -> ParsecT s u m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 (m :: * -> *) a. Monad m => a -> m a
return [] else ParsecT s u m [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero)

    isAsciiAlpha :: Char -> Bool
isAsciiAlpha c :: Char
c = Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isAlpha Char
c
    alphas :: Int -> ParsecT [Text] () Identity Text
alphas len :: Int
len = (Text -> Bool) -> ParsecT [Text] () Identity Text
tok (\t :: 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 len :: Int
len = (Text -> Bool) -> ParsecT [Text] () Identity Text
tok (\t :: 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 minLen :: Int
minLen maxLen :: Int
maxLen =
      (Text -> Bool) -> ParsecT [Text] () Identity Text
tok (\t :: 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 minLen :: Int
minLen maxLen :: Int
maxLen =
      (Text -> Bool) -> ParsecT [Text] () Identity Text
tok (\t :: 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 lo :: Int
lo hi :: Int
hi t :: 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 c :: 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 :: b -> Either a b -> b
fromRight fallback :: b
fallback (Left _)  = b
fallback
fromRight _        (Right x :: b
x) = b
x