{-# 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
  )
where

import Control.Applicative ((<|>))
import Control.Monad (MonadPlus)
import Country.Identifier
  ( unitedKingdomOfGreatBritainAndNorthernIreland
  , unitedStatesOfAmerica
  )
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)
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
$c== :: BCP47 -> BCP47 -> Bool
== :: BCP47 -> BCP47 -> Bool
$c/= :: BCP47 -> BCP47 -> Bool
/= :: 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
$ccompare :: BCP47 -> BCP47 -> Ordering
compare :: BCP47 -> BCP47 -> Ordering
$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
>= :: BCP47 -> BCP47 -> Bool
$cmax :: BCP47 -> BCP47 -> BCP47
max :: BCP47 -> BCP47 -> BCP47
$cmin :: BCP47 -> BCP47 -> BCP47
min :: BCP47 -> BCP47 -> 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. HasCallStack => [a] -> Gen a
elements [ISO639_1
EN, ISO639_1
ES] Gen (Set Subtags -> BCP47) -> Gen (Set Subtags) -> Gen BCP47
forall a b. Gen (a -> b) -> Gen a -> Gen b
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 a b. Gen a -> (a -> Gen b) -> Gen b
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)
forall (f :: * -> *) a. Applicative f => [f a] -> f [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 a b. Gen a -> (a -> Gen b) -> Gen b
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. HasCallStack => [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
"")]

-- | 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 :: forall a. Ord a => (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 :: forall x. [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 a. Set a -> [a]
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 <$> fromText (pack "en-GB-t-jp")
-- Right [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 a b c. (a -> b) -> Either a c -> Either b c
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 a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
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 a b c. (a -> b) -> Either a c -> Either b c
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 a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
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 a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
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)
forall (f :: * -> *) a. Applicative f => [f a] -> f [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 a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
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 a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
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 a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
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 a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
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 a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Script -> ParsecT Void Text Identity (Maybe Script)
forall a. a -> ParsecT Void Text Identity a
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 a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
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 a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
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 a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Country -> ParsecT Void Text Identity (Maybe Country)
forall a. a -> ParsecT Void Text Identity a
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 a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
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 a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
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 a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
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 a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
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 a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
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 a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
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 a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
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 :: forall b (m :: * -> *) a.
(Ord b, MonadPlus m) =>
(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