{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- | /Human beings on our planet have, past and present, used a number of/
-- /languages. There are many reasons why one would want to identify the/
-- /language used when presenting or requesting information./
--
-- /The language of an information item or a user's language preferences often/
-- /need to be identified so that appropriate processing can be applied. For/
-- /example, the user's language preferences in a Web browser can be used to/
-- /select Web pages appropriately. Language information can also be used to/
-- /select among tools (such as dictionaries) to assist in the processing or/
-- /understanding of content in different languages.  Knowledge about the/
-- /particular language used by some piece of information content might be useful/
-- /or even required by some types of processing, for example, spell-checking,/
-- /computer-synthesized speech, Braille transcription, or high-quality print/
-- /renderings./
--
-- / - /<https://tools.ietf.org/html/bcp47>
--
module Data.BCP47
  ( BCP47
  , inits
  -- * Construction
  , mkLanguage
  , mkLocalized
  , fromText
  , parser
  -- * Serialization
  , toText
  -- * Subtags
  -- | A language tag is composed from a sequence of one or more "subtags",
  -- each of which refines or narrows the range of language identified by
  -- the overall tag. Subtags, in turn, are a sequence of alphanumeric characters
  -- (letters and digits), distinguished and separated from other subtags in a tag
  -- by a hyphen ("-", [Unicode] U+002D).
  , toSubtags
  -- ** Language
  , ISO639_1
  , language
  , languageToText
  , languageFromText
  -- ** Language Extension
  , LanguageExtension
  , extendedLanguageSubtags
  , languageExtensionToText
  , languageExtensionFromText
  -- ** Language Script
  , Script
  , script
  , scriptToText
  , scriptFromText
  -- ** Region
  , Country
  , region
  , regionToText
  , regionFromText
  -- ** Variant
  , Variant
  , variants
  , variantToText
  , variantFromText
  -- ** Extension
  , Extension
  , extensions
  , extensionToText
  , extensionFromText
  -- ** Private Use
  , PrivateUse
  , privateUse
  , privateUseToText
  , privateUseFromText
  -- * For testing
  , en
  , es
  , sw
  , enGB
  , enUS
  , enTJP
  , enGBTJP
  )
where

import Control.Applicative ((<|>))
import Control.Monad (MonadPlus)
import Country.Identifier
  (unitedKingdomOfGreatBritainAndNorthernIreland, unitedStatesOfAmerica)
import Data.Aeson
import Data.BCP47.Internal.Arbitrary
  (Arbitrary, arbitrary, choose, elements, listOf, vectorOf)
import Data.BCP47.Internal.Extension
import Data.BCP47.Internal.Language
import Data.BCP47.Internal.LanguageExtension
import Data.BCP47.Internal.PrivateUse
import Data.BCP47.Internal.Region
import Data.BCP47.Internal.Script
import Data.BCP47.Internal.Subtags
import Data.BCP47.Internal.Variant
import Data.Bifunctor (first)
import Data.Foldable (toList)
import Data.LanguageCodes (ISO639_1(EN, ES, SW))
import qualified Data.List as List
import Data.Maybe (mapMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T
import Data.Void (Void)
import Text.Megaparsec (Parsec, eof, hidden, many, optional, parse, try)
import Text.Megaparsec.Char (char)
import Text.Megaparsec.Error (errorBundlePretty)

-- | A language tag
--
-- Language tags are used to help identify languages, whether spoken, written,
-- signed, or otherwise signaled, for the purpose of communication. This
-- includes constructed and artificial languages but excludes languages not
-- intended primarily for human communication, such as programming languages.
--
data BCP47
  = BCP47
  { BCP47 -> ISO639_1
language :: ISO639_1 -- ^ The language subtag
  , BCP47 -> Set Subtags
subtags :: Set Subtags
  }
  deriving stock (BCP47 -> BCP47 -> Bool
(BCP47 -> BCP47 -> Bool) -> (BCP47 -> BCP47 -> Bool) -> Eq BCP47
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BCP47 -> BCP47 -> Bool
$c/= :: BCP47 -> BCP47 -> Bool
== :: BCP47 -> BCP47 -> Bool
$c== :: BCP47 -> BCP47 -> Bool
Eq, Eq BCP47
Eq BCP47
-> (BCP47 -> BCP47 -> Ordering)
-> (BCP47 -> BCP47 -> Bool)
-> (BCP47 -> BCP47 -> Bool)
-> (BCP47 -> BCP47 -> Bool)
-> (BCP47 -> BCP47 -> Bool)
-> (BCP47 -> BCP47 -> BCP47)
-> (BCP47 -> BCP47 -> BCP47)
-> Ord BCP47
BCP47 -> BCP47 -> Bool
BCP47 -> BCP47 -> Ordering
BCP47 -> BCP47 -> BCP47
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 :: BCP47 -> BCP47 -> BCP47
$cmin :: BCP47 -> BCP47 -> BCP47
max :: BCP47 -> BCP47 -> BCP47
$cmax :: BCP47 -> BCP47 -> BCP47
>= :: BCP47 -> BCP47 -> Bool
$c>= :: BCP47 -> BCP47 -> Bool
> :: BCP47 -> BCP47 -> Bool
$c> :: BCP47 -> BCP47 -> Bool
<= :: BCP47 -> BCP47 -> Bool
$c<= :: BCP47 -> BCP47 -> Bool
< :: BCP47 -> BCP47 -> Bool
$c< :: BCP47 -> BCP47 -> Bool
compare :: BCP47 -> BCP47 -> Ordering
$ccompare :: BCP47 -> BCP47 -> Ordering
$cp1Ord :: Eq BCP47
Ord)

instance Arbitrary BCP47 where
  arbitrary :: Gen BCP47
arbitrary = ISO639_1 -> Set Subtags -> BCP47
BCP47 (ISO639_1 -> Set Subtags -> BCP47)
-> Gen ISO639_1 -> Gen (Set Subtags -> BCP47)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ISO639_1] -> Gen ISO639_1
forall a. [a] -> Gen a
elements [ISO639_1
EN, ISO639_1
ES] Gen (Set Subtags -> BCP47) -> Gen (Set Subtags) -> Gen BCP47
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Set Subtags)
specs
   where
    oneOrNone :: (a -> a) -> Gen [a]
oneOrNone a -> a
f = (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
1) Gen Int -> (Int -> Gen [a]) -> Gen [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int -> Gen a -> Gen [a]
forall a. Int -> Gen a -> Gen [a]
`vectorOf` (a -> a
f (a -> a) -> Gen a -> Gen a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
arbitrary))
    manyOf :: (a -> a) -> Gen [a]
manyOf a -> a
f = Gen a -> Gen [a]
forall a. Gen a -> Gen [a]
listOf (a -> a
f (a -> a) -> Gen a -> Gen a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
arbitrary)
    regions :: [Country]
regions = [Country
forall a. Bounded a => a
minBound .. Country
forall a. Bounded a => a
maxBound]
    specs :: Gen (Set Subtags)
specs = [Subtags] -> Set Subtags
forall a. Ord a => [a] -> Set a
Set.fromList ([Subtags] -> Set Subtags)
-> ([[Subtags]] -> [Subtags]) -> [[Subtags]] -> Set Subtags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Subtags]] -> [Subtags]
forall a. Monoid a => [a] -> a
mconcat ([[Subtags]] -> Set Subtags)
-> Gen [[Subtags]] -> Gen (Set Subtags)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Gen [Subtags]] -> Gen [[Subtags]]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
      [ (LanguageExtension -> Subtags) -> Gen [Subtags]
forall a a. Arbitrary a => (a -> a) -> Gen [a]
manyOf LanguageExtension -> Subtags
SpecifyLanguageExtension
      , (Script -> Subtags) -> Gen [Subtags]
forall a a. Arbitrary a => (a -> a) -> Gen [a]
oneOrNone Script -> Subtags
SpecifyScript
      , (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
1) Gen Int -> (Int -> Gen [Subtags]) -> Gen [Subtags]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int -> Gen Subtags -> Gen [Subtags]
forall a. Int -> Gen a -> Gen [a]
`vectorOf` ([Subtags] -> Gen Subtags
forall a. [a] -> Gen a
elements ([Subtags] -> Gen Subtags) -> [Subtags] -> Gen Subtags
forall a b. (a -> b) -> a -> b
$ Country -> Subtags
SpecifyRegion (Country -> Subtags) -> [Country] -> [Subtags]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Country]
regions))
      , (Variant -> Subtags) -> Gen [Subtags]
forall a a. Arbitrary a => (a -> a) -> Gen [a]
manyOf Variant -> Subtags
SpecifyVariant
      , (Extension -> Subtags) -> Gen [Subtags]
forall a a. Arbitrary a => (a -> a) -> Gen [a]
manyOf Extension -> Subtags
SpecifyExtension
      , (PrivateUse -> Subtags) -> Gen [Subtags]
forall a a. Arbitrary a => (a -> a) -> Gen [a]
oneOrNone PrivateUse -> Subtags
SpecifyPrivateUse
      ]

instance Show BCP47 where
  show :: BCP47 -> String
show = Text -> String
T.unpack (Text -> String) -> (BCP47 -> Text) -> BCP47 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BCP47 -> Text
toText

instance Read BCP47 where
  readsPrec :: Int -> ReadS BCP47
readsPrec Int
_ String
s = case Text -> Either Text BCP47
fromText (Text -> Either Text BCP47) -> Text -> Either Text BCP47
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s of
    Left Text
_ -> []
    Right BCP47
b -> [(BCP47
b, String
"")]

instance ToJSON BCP47 where
  toEncoding :: BCP47 -> Encoding
toEncoding = Text -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (Text -> Encoding) -> (BCP47 -> Text) -> BCP47 -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BCP47 -> Text
toText
  toJSON :: BCP47 -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (BCP47 -> Text) -> BCP47 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BCP47 -> Text
toText

instance FromJSON BCP47 where
  parseJSON :: Value -> Parser BCP47
parseJSON = String -> (Text -> Parser BCP47) -> Value -> Parser BCP47
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"BCP47" ((Text -> Parser BCP47) -> Value -> Parser BCP47)
-> (Text -> Parser BCP47) -> Value -> Parser BCP47
forall a b. (a -> b) -> a -> b
$ (Text -> Parser BCP47)
-> (BCP47 -> Parser BCP47) -> Either Text BCP47 -> Parser BCP47
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser BCP47
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser BCP47)
-> (Text -> String) -> Text -> Parser BCP47
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack) BCP47 -> Parser BCP47
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text BCP47 -> Parser BCP47)
-> (Text -> Either Text BCP47) -> Text -> Parser BCP47
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text BCP47
fromText

-- | Serialize @'BCP47'@ to @'Text'@
--
-- Subtags are serialized in the order described in the BCP 47 specification.
-- Private-use subtags only appear at the end prefixed with an x.
--
toText :: BCP47 -> Text
toText :: BCP47 -> Text
toText BCP47
b = Text -> [Text] -> Text
T.intercalate Text
"-" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall a. Monoid a => [a] -> a
mconcat
  [ [ISO639_1 -> Text
languageToText (ISO639_1 -> Text) -> ISO639_1 -> Text
forall a b. (a -> b) -> a -> b
$ BCP47 -> ISO639_1
language BCP47
b]
  , (Subtags -> Maybe Text) -> [Subtags] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Subtags -> Maybe Text
fromSubtags ([Subtags] -> [Text])
-> (Set Subtags -> [Subtags]) -> Set Subtags -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Subtags -> [Subtags]
forall a. Set a -> [a]
Set.toList (Set Subtags -> [Text]) -> Set Subtags -> [Text]
forall a b. (a -> b) -> a -> b
$ BCP47 -> Set Subtags
subtags BCP47
b
  , if Set PrivateUse -> Bool
forall a. Set a -> Bool
Set.null (BCP47 -> Set PrivateUse
privateUse BCP47
b) then [] else [Text
"x"]
  , (PrivateUse -> Text) -> [PrivateUse] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map PrivateUse -> Text
privateUseToText ([PrivateUse] -> [Text])
-> (Set PrivateUse -> [PrivateUse]) -> Set PrivateUse -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set PrivateUse -> [PrivateUse]
forall a. Set a -> [a]
Set.toList (Set PrivateUse -> [Text]) -> Set PrivateUse -> [Text]
forall a b. (a -> b) -> a -> b
$ BCP47 -> Set PrivateUse
privateUse BCP47
b
  ]
 where
  fromSubtags :: Subtags -> Maybe Text
fromSubtags = \case
    SpecifyLanguageExtension LanguageExtension
x -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ LanguageExtension -> Text
languageExtensionToText LanguageExtension
x
    SpecifyScript Script
x -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Script -> Text
scriptToText Script
x
    SpecifyRegion Country
x -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Country -> Text
regionToText Country
x
    SpecifyVariant Variant
x -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Variant -> Text
variantToText Variant
x
    SpecifyExtension Extension
x -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Extension -> Text
extensionToText Extension
x
    SpecifyPrivateUse PrivateUse
_ -> Maybe Text
forall a. Maybe a
Nothing

-- | Look up all language extension subtags
extendedLanguageSubtags :: BCP47 -> Set LanguageExtension
extendedLanguageSubtags :: BCP47 -> Set LanguageExtension
extendedLanguageSubtags = (Subtags -> Maybe LanguageExtension)
-> BCP47 -> Set LanguageExtension
forall a. Ord a => (Subtags -> Maybe a) -> BCP47 -> Set a
asSet ((Subtags -> Maybe LanguageExtension)
 -> BCP47 -> Set LanguageExtension)
-> (Subtags -> Maybe LanguageExtension)
-> BCP47
-> Set LanguageExtension
forall a b. (a -> b) -> a -> b
$ \case
  SpecifyLanguageExtension LanguageExtension
x -> LanguageExtension -> Maybe LanguageExtension
forall a. a -> Maybe a
Just LanguageExtension
x
  Subtags
_otherwise -> Maybe LanguageExtension
forall a. Maybe a
Nothing

-- | Look up the script subtag
script :: BCP47 -> Maybe Script
script :: BCP47 -> Maybe Script
script = [Script] -> Maybe Script
forall x. [x] -> Maybe x
headMay ([Script] -> Maybe Script)
-> (BCP47 -> [Script]) -> BCP47 -> Maybe Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Subtags -> Maybe Script) -> [Subtags] -> [Script]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Subtags -> Maybe Script
f ([Subtags] -> [Script])
-> (BCP47 -> [Subtags]) -> BCP47 -> [Script]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Subtags -> [Subtags]
forall a. Set a -> [a]
Set.toList (Set Subtags -> [Subtags])
-> (BCP47 -> Set Subtags) -> BCP47 -> [Subtags]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BCP47 -> Set Subtags
subtags
 where
  f :: Subtags -> Maybe Script
f = \case
    SpecifyScript Script
x -> Script -> Maybe Script
forall a. a -> Maybe a
Just Script
x
    Subtags
_otherwise -> Maybe Script
forall a. Maybe a
Nothing

-- | Look up the region subtag
region :: BCP47 -> Maybe Country
region :: BCP47 -> Maybe Country
region = [Country] -> Maybe Country
forall x. [x] -> Maybe x
headMay ([Country] -> Maybe Country)
-> (BCP47 -> [Country]) -> BCP47 -> Maybe Country
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Subtags -> Maybe Country) -> [Subtags] -> [Country]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Subtags -> Maybe Country
f ([Subtags] -> [Country])
-> (BCP47 -> [Subtags]) -> BCP47 -> [Country]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Subtags -> [Subtags]
forall a. Set a -> [a]
Set.toList (Set Subtags -> [Subtags])
-> (BCP47 -> Set Subtags) -> BCP47 -> [Subtags]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BCP47 -> Set Subtags
subtags
 where
  f :: Subtags -> Maybe Country
f = \case
    SpecifyRegion Country
x -> Country -> Maybe Country
forall a. a -> Maybe a
Just Country
x
    Subtags
_otherwise -> Maybe Country
forall a. Maybe a
Nothing

-- | Look up all variant subtags
variants :: BCP47 -> Set Variant
variants :: BCP47 -> Set Variant
variants = (Subtags -> Maybe Variant) -> BCP47 -> Set Variant
forall a. Ord a => (Subtags -> Maybe a) -> BCP47 -> Set a
asSet ((Subtags -> Maybe Variant) -> BCP47 -> Set Variant)
-> (Subtags -> Maybe Variant) -> BCP47 -> Set Variant
forall a b. (a -> b) -> a -> b
$ \case
  SpecifyVariant Variant
x -> Variant -> Maybe Variant
forall a. a -> Maybe a
Just Variant
x
  Subtags
_otherwise -> Maybe Variant
forall a. Maybe a
Nothing

-- | Look up all extension subtags
extensions :: BCP47 -> Set Extension
extensions :: BCP47 -> Set Extension
extensions = (Subtags -> Maybe Extension) -> BCP47 -> Set Extension
forall a. Ord a => (Subtags -> Maybe a) -> BCP47 -> Set a
asSet ((Subtags -> Maybe Extension) -> BCP47 -> Set Extension)
-> (Subtags -> Maybe Extension) -> BCP47 -> Set Extension
forall a b. (a -> b) -> a -> b
$ \case
  SpecifyExtension Extension
x -> Extension -> Maybe Extension
forall a. a -> Maybe a
Just Extension
x
  Subtags
_otherwise -> Maybe Extension
forall a. Maybe a
Nothing

-- | Look up all private use subtags
privateUse :: BCP47 -> Set PrivateUse
privateUse :: BCP47 -> Set PrivateUse
privateUse = (Subtags -> Maybe PrivateUse) -> BCP47 -> Set PrivateUse
forall a. Ord a => (Subtags -> Maybe a) -> BCP47 -> Set a
asSet ((Subtags -> Maybe PrivateUse) -> BCP47 -> Set PrivateUse)
-> (Subtags -> Maybe PrivateUse) -> BCP47 -> Set PrivateUse
forall a b. (a -> b) -> a -> b
$ \case
  SpecifyPrivateUse PrivateUse
x -> PrivateUse -> Maybe PrivateUse
forall a. a -> Maybe a
Just PrivateUse
x
  Subtags
_otherwise -> Maybe PrivateUse
forall a. Maybe a
Nothing

asSet :: Ord a => (Subtags -> Maybe a) -> BCP47 -> Set a
asSet :: (Subtags -> Maybe a) -> BCP47 -> Set a
asSet Subtags -> Maybe a
f = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList ([a] -> Set a) -> (BCP47 -> [a]) -> BCP47 -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Subtags -> Maybe a) -> [Subtags] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Subtags -> Maybe a
f ([Subtags] -> [a]) -> (BCP47 -> [Subtags]) -> BCP47 -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Subtags -> [Subtags]
forall a. Set a -> [a]
Set.toList (Set Subtags -> [Subtags])
-> (BCP47 -> Set Subtags) -> BCP47 -> [Subtags]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BCP47 -> Set Subtags
subtags

headMay :: [x] -> Maybe x
headMay :: [x] -> Maybe x
headMay [] = Maybe x
forall a. Maybe a
Nothing
headMay (x
x : [x]
_) = x -> Maybe x
forall a. a -> Maybe a
Just x
x

-- | Convert tag to list of subtags
toSubtags :: BCP47 -> [Subtags]
toSubtags :: BCP47 -> [Subtags]
toSubtags BCP47
tag = Set Subtags -> [Subtags]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set Subtags -> [Subtags]) -> Set Subtags -> [Subtags]
forall a b. (a -> b) -> a -> b
$ BCP47 -> Set Subtags
subtags BCP47
tag

-- | Produce a list of @(<= priority)@ language tags
--
-- >>> inits enGBTJP
-- [en,en-GB,en-GB-t-jp]
--
inits :: BCP47 -> [BCP47]
inits :: BCP47 -> [BCP47]
inits BCP47
tag =
  ([Subtags] -> BCP47) -> [[Subtags]] -> [BCP47]
forall a b. (a -> b) -> [a] -> [b]
map (ISO639_1 -> Set Subtags -> BCP47
BCP47 (BCP47 -> ISO639_1
language BCP47
tag) (Set Subtags -> BCP47)
-> ([Subtags] -> Set Subtags) -> [Subtags] -> BCP47
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Subtags] -> Set Subtags
forall a. Ord a => [a] -> Set a
Set.fromList) ([[Subtags]] -> [BCP47])
-> ([Subtags] -> [[Subtags]]) -> [Subtags] -> [BCP47]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Subtags] -> [[Subtags]]
forall a. [a] -> [[a]]
List.inits ([Subtags] -> [BCP47]) -> [Subtags] -> [BCP47]
forall a b. (a -> b) -> a -> b
$ BCP47 -> [Subtags]
toSubtags BCP47
tag

-- | Construct a simple language tag
mkLanguage :: ISO639_1 -> BCP47
mkLanguage :: ISO639_1 -> BCP47
mkLanguage ISO639_1
lang = ISO639_1 -> Set Subtags -> BCP47
BCP47 ISO639_1
lang Set Subtags
forall a. Monoid a => a
mempty

-- | Construct a localized tag
mkLocalized :: ISO639_1 -> Country -> BCP47
mkLocalized :: ISO639_1 -> Country -> BCP47
mkLocalized ISO639_1
lang Country
locale = ISO639_1 -> Set Subtags -> BCP47
BCP47 ISO639_1
lang (Set Subtags -> BCP47)
-> (Subtags -> Set Subtags) -> Subtags -> BCP47
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subtags -> Set Subtags
forall a. a -> Set a
Set.singleton (Subtags -> BCP47) -> Subtags -> BCP47
forall a b. (a -> b) -> a -> b
$ Country -> Subtags
SpecifyRegion Country
locale

-- | Parse a language tag from text
--
-- >>> fromText $ pack "en"
-- Right en
--
-- >>> fromText $ pack "de-CH"
-- Right de-CH
--
-- >>> fromText $ pack "ru-USR"
-- Left "fromText:1:3:\n  |\n1 | ru-USR\n  |   ^\nunexpected '-'\n"
--
-- >>> fromText $ pack "en-a-ccc-v-qqq-a-bbb"
-- Right en-a-bbb-a-ccc-v-qqq
--
-- >>> fromText $ pack "de-Latn-DE"
-- Right de-Latn-DE
--
-- >>> fromText $ pack "de-Latf-DE"
-- Right de-Latf-DE
--
-- >>> fromText $ pack "de-CH-1996"
-- Right de-CH-1996
--
-- >>> fromText $ pack "de-Deva"
-- Right de-Deva
--
-- >>> fromText $ pack "zh-Hant-CN-x-private1-private2"
-- Right zh-Hant-CN-x-private1-private2
--
-- >>> fromText $ pack "zh-Hant-CN-x-private1"
-- Right zh-Hant-CN-x-private1
--
-- >>> fromText $ pack "zh-Hant-CN"
-- Right zh-Hant-CN
--
-- >>> fromText $ pack "zh-Hant"
-- Right zh-Hant
--
-- >>> fromText $ pack "zh"
-- Right zh
--
fromText :: Text -> Either Text BCP47
fromText :: Text -> Either Text BCP47
fromText =
  (ParseErrorBundle Text Void -> Text)
-> Either (ParseErrorBundle Text Void) BCP47 -> Either Text BCP47
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
pack (String -> Text)
-> (ParseErrorBundle Text Void -> String)
-> ParseErrorBundle Text Void
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) (Either (ParseErrorBundle Text Void) BCP47 -> Either Text BCP47)
-> (Text -> Either (ParseErrorBundle Text Void) BCP47)
-> Text
-> Either Text BCP47
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text BCP47
-> String -> Text -> Either (ParseErrorBundle Text Void) BCP47
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Parsec Void Text BCP47
parser Parsec Void Text BCP47
-> ParsecT Void Text Identity () -> Parsec Void Text BCP47
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
hidden ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
"fromText"

-- |
--
-- >>> _example $ pack "en;"
-- Right (en,';')
--
_example :: Text -> Either Text (BCP47, Char)
_example :: Text -> Either Text (BCP47, Char)
_example = (ParseErrorBundle Text Void -> Text)
-> Either (ParseErrorBundle Text Void) (BCP47, Char)
-> Either Text (BCP47, Char)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
pack (String -> Text)
-> (ParseErrorBundle Text Void -> String)
-> ParseErrorBundle Text Void
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) (Either (ParseErrorBundle Text Void) (BCP47, Char)
 -> Either Text (BCP47, Char))
-> (Text -> Either (ParseErrorBundle Text Void) (BCP47, Char))
-> Text
-> Either Text (BCP47, Char)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text (BCP47, Char)
-> String
-> Text
-> Either (ParseErrorBundle Text Void) (BCP47, Char)
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void Text (BCP47, Char)
p String
"example"
  where p :: Parsec Void Text (BCP47, Char)
p = (,) (BCP47 -> Char -> (BCP47, Char))
-> Parsec Void Text BCP47
-> ParsecT Void Text Identity (Char -> (BCP47, Char))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text BCP47
parser ParsecT Void Text Identity (Char -> (BCP47, Char))
-> ParsecT Void Text Identity Char
-> Parsec Void Text (BCP47, Char)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
';'

parser :: Parsec Void Text BCP47
parser :: Parsec Void Text BCP47
parser = ISO639_1 -> Set Subtags -> BCP47
BCP47 (ISO639_1 -> Set Subtags -> BCP47)
-> ParsecT Void Text Identity ISO639_1
-> ParsecT Void Text Identity (Set Subtags -> BCP47)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity ISO639_1
languageP ParsecT Void Text Identity (Set Subtags -> BCP47)
-> ParsecT Void Text Identity (Set Subtags)
-> Parsec Void Text BCP47
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity (Set Subtags)
subtagsP
 where
  subtagsP :: ParsecT Void Text Identity (Set Subtags)
subtagsP = [Set Subtags] -> Set Subtags
forall a. Monoid a => [a] -> a
mconcat ([Set Subtags] -> Set Subtags)
-> ParsecT Void Text Identity [Set Subtags]
-> ParsecT Void Text Identity (Set Subtags)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParsecT Void Text Identity (Set Subtags)]
-> ParsecT Void Text Identity [Set Subtags]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
    [ (LanguageExtension -> Subtags)
-> ParsecT Void Text Identity LanguageExtension
-> ParsecT Void Text Identity (Set Subtags)
forall b (m :: * -> *) a.
(Ord b, MonadPlus m) =>
(a -> b) -> m a -> m (Set b)
manyAsSet LanguageExtension -> Subtags
SpecifyLanguageExtension (ParsecT Void Text Identity LanguageExtension
-> ParsecT Void Text Identity LanguageExtension
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity LanguageExtension
-> ParsecT Void Text Identity LanguageExtension
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity LanguageExtension
languageExtensionP))
    , Set Subtags
-> (Script -> Set Subtags) -> Maybe Script -> Set Subtags
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Subtags
forall a. Monoid a => a
mempty (Subtags -> Set Subtags
forall a. a -> Set a
Set.singleton (Subtags -> Set Subtags)
-> (Script -> Subtags) -> Script -> Set Subtags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script -> Subtags
SpecifyScript)
      (Maybe Script -> Set Subtags)
-> ParsecT Void Text Identity (Maybe Script)
-> ParsecT Void Text Identity (Set Subtags)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void Text Identity (Maybe Script)
-> ParsecT Void Text Identity (Maybe Script)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity Script
-> ParsecT Void Text Identity (Maybe Script)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT Void Text Identity Script
 -> ParsecT Void Text Identity (Maybe Script))
-> ParsecT Void Text Identity Script
-> ParsecT Void Text Identity (Maybe Script)
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Script
-> ParsecT Void Text Identity Script
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Script
scriptP) ParsecT Void Text Identity (Maybe Script)
-> ParsecT Void Text Identity (Maybe Script)
-> ParsecT Void Text Identity (Maybe Script)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Script -> ParsecT Void Text Identity (Maybe Script)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Script
forall a. Maybe a
Nothing)
    , Set Subtags
-> (Country -> Set Subtags) -> Maybe Country -> Set Subtags
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Subtags
forall a. Monoid a => a
mempty (Subtags -> Set Subtags
forall a. a -> Set a
Set.singleton (Subtags -> Set Subtags)
-> (Country -> Subtags) -> Country -> Set Subtags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Country -> Subtags
SpecifyRegion)
      (Maybe Country -> Set Subtags)
-> ParsecT Void Text Identity (Maybe Country)
-> ParsecT Void Text Identity (Set Subtags)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void Text Identity (Maybe Country)
-> ParsecT Void Text Identity (Maybe Country)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity Country
-> ParsecT Void Text Identity (Maybe Country)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT Void Text Identity Country
 -> ParsecT Void Text Identity (Maybe Country))
-> ParsecT Void Text Identity Country
-> ParsecT Void Text Identity (Maybe Country)
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Country
-> ParsecT Void Text Identity Country
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Country
regionP) ParsecT Void Text Identity (Maybe Country)
-> ParsecT Void Text Identity (Maybe Country)
-> ParsecT Void Text Identity (Maybe Country)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Country -> ParsecT Void Text Identity (Maybe Country)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Country
forall a. Maybe a
Nothing)
    , (Variant -> Subtags)
-> ParsecT Void Text Identity Variant
-> ParsecT Void Text Identity (Set Subtags)
forall b (m :: * -> *) a.
(Ord b, MonadPlus m) =>
(a -> b) -> m a -> m (Set b)
manyAsSet Variant -> Subtags
SpecifyVariant (ParsecT Void Text Identity Variant
-> ParsecT Void Text Identity Variant
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Variant
-> ParsecT Void Text Identity Variant
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Variant
variantP))
    , (Extension -> Subtags)
-> ParsecT Void Text Identity Extension
-> ParsecT Void Text Identity (Set Subtags)
forall b (m :: * -> *) a.
(Ord b, MonadPlus m) =>
(a -> b) -> m a -> m (Set b)
manyAsSet Extension -> Subtags
SpecifyExtension (ParsecT Void Text Identity Extension
-> ParsecT Void Text Identity Extension
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Extension
-> ParsecT Void Text Identity Extension
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Extension
extensionP))
    , (PrivateUse -> Subtags) -> Set PrivateUse -> Set Subtags
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map PrivateUse -> Subtags
SpecifyPrivateUse (Set PrivateUse -> Set Subtags)
-> ParsecT Void Text Identity (Set PrivateUse)
-> ParsecT Void Text Identity (Set Subtags)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void Text Identity (Set PrivateUse)
-> ParsecT Void Text Identity (Set PrivateUse)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Set PrivateUse)
-> ParsecT Void Text Identity (Set PrivateUse)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity (Set PrivateUse)
privateUseP) ParsecT Void Text Identity (Set PrivateUse)
-> ParsecT Void Text Identity (Set PrivateUse)
-> ParsecT Void Text Identity (Set PrivateUse)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity (Set PrivateUse)
forall a. Monoid a => a
mempty)
    ]

manyAsSet :: (Ord b, MonadPlus m) => (a -> b) -> m a -> m (Set b)
manyAsSet :: (a -> b) -> m a -> m (Set b)
manyAsSet a -> b
f m a
p = [b] -> Set b
forall a. Ord a => [a] -> Set a
Set.fromList ([b] -> Set b) -> ([a] -> [b]) -> [a] -> Set b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f ([a] -> Set b) -> m [a] -> m (Set b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a -> m [a]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many m a
p

-- | Spanish
es :: BCP47
es :: BCP47
es = ISO639_1 -> BCP47
mkLanguage ISO639_1
ES

-- | English
en :: BCP47
en :: BCP47
en = ISO639_1 -> BCP47
mkLanguage ISO639_1
EN

-- | Swahili
sw :: BCP47
sw :: BCP47
sw = ISO639_1 -> BCP47
mkLanguage ISO639_1
SW

-- | British English
enGB :: BCP47
enGB :: BCP47
enGB = ISO639_1 -> Country -> BCP47
mkLocalized ISO639_1
EN Country
unitedKingdomOfGreatBritainAndNorthernIreland

-- | American English
enUS :: BCP47
enUS :: BCP47
enUS = ISO639_1 -> Country -> BCP47
mkLocalized ISO639_1
EN Country
unitedStatesOfAmerica

-- | A nonsense tag @en-t-jp@
enTJP :: BCP47
enTJP :: BCP47
enTJP = BCP47
en
  { subtags :: Set Subtags
subtags = Subtags -> Set Subtags -> Set Subtags
forall a. Ord a => a -> Set a -> Set a
Set.insert (Extension -> Subtags
SpecifyExtension (Text -> Extension
Extension (String -> Text
pack String
"t-jp")))
    (Set Subtags -> Set Subtags) -> Set Subtags -> Set Subtags
forall a b. (a -> b) -> a -> b
$ BCP47 -> Set Subtags
subtags BCP47
en
  }

-- | A nonsense tag @en-GB-t-jp@
enGBTJP :: BCP47
enGBTJP :: BCP47
enGBTJP = BCP47
enGB
  { subtags :: Set Subtags
subtags = Subtags -> Set Subtags -> Set Subtags
forall a. Ord a => a -> Set a -> Set a
Set.insert (Extension -> Subtags
SpecifyExtension (Text -> Extension
Extension (String -> Text
pack String
"t-jp")))
    (Set Subtags -> Set Subtags) -> Set Subtags -> Set Subtags
forall a b. (a -> b) -> a -> b
$ BCP47 -> Set Subtags
subtags BCP47
enGB
  }