bcp47 0.2.0.6 → 0.3.0.0

raw patch · 18 files changed

+434/−209 lines, 18 filesdep +case-insensitivedep −aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: case-insensitive

Dependencies removed: aeson

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−1
• bcp47.cabal +5/−4
• library/Data/BCP47.hs +77/−80
• library/Data/BCP47/Internal/CIText.hs +39/−0
• library/Data/BCP47/Internal/Extension.hs +20/−11
• library/Data/BCP47/Internal/Language.hs +8/−6
• library/Data/BCP47/Internal/LanguageExtension.hs +17/−13
• library/Data/BCP47/Internal/Parser.hs +41/−2
• library/Data/BCP47/Internal/PrivateUse.hs +19/−11
• library/Data/BCP47/Internal/Region.hs +28/−18
• library/Data/BCP47/Internal/Script.hs +10/−8
• library/Data/BCP47/Internal/Subtags.hs +10/−11
• library/Data/BCP47/Internal/Variant.hs +24/−16
• library/Data/BCP47/Trie.hs +0/−2
• library/Data/BCP47/Trie/Internal.hs +12/−12
• tests/Data/BCP47/TrieSpec.hs +14/−3
• tests/Data/BCP47Spec.hs +60/−11
• tests/TestImport.hs +45/−0

@@ -1,6 +1,10 @@-## [*Unreleased*](https://github.com/freckle/bcp47/compare/bcp47-v0.2.0.6...main)+## [*Unreleased*](https://github.com/freckle/bcp47/compare/bcp47-v0.3.0.0...main)  None++## [v0.3.0.0](https://github.com/freckle/bcp47/compare/bcp47-v0.2.0.6...bcp47-v0.3.0.0)++- Remove `FromJSON` and `ToJSON` instances (added to `bcp47-orphans-0.1.1.0`)  ## [v0.2.0.6](https://github.com/freckle/bcp47/compare/bcp47-v0.2.0.5...bcp47-v0.2.0.6) 

@@ -1,6 +1,6 @@ cabal-version:      1.12 name:               bcp47-version:            0.2.0.6+version:            0.3.0.0 license:            MIT license-file:       LICENSE copyright:          2019 Freckle Education@@ -44,6 +44,7 @@     exposed-modules:         Data.BCP47         Data.BCP47.Internal.Arbitrary+        Data.BCP47.Internal.CIText         Data.BCP47.Internal.Extension         Data.BCP47.Internal.Language         Data.BCP47.Internal.LanguageExtension@@ -61,8 +62,8 @@     default-language: Haskell2010     build-depends:         QuickCheck >=2.11.3,-        aeson >=1.3.1.1,         base >=4.7 && <5,+        case-insensitive >=1.2.0.11,         containers >=0.5.11.0,         country >=0.1.6,         generic-arbitrary >=0.1.0,@@ -87,14 +88,14 @@     other-modules:         Data.BCP47.TrieSpec         Data.BCP47Spec+        TestImport         Paths_bcp47      default-language: Haskell2010     build-depends:         QuickCheck >=2.11.3,-        aeson >=1.3.1.1,         base >=4.7 && <5,-        bcp47 -any,+        bcp47,         containers >=0.5.11.0,         country >=0.1.6,         hspec >=2.5.5,

@@ -18,77 +18,93 @@ -- /renderings./ -- -- / - /<https://tools.ietf.org/html/bcp47>--- module Data.BCP47   ( BCP47   , inits-  -- * Construction++    -- * Construction   , mkLanguage   , mkLocalized   , fromText   , parser-  -- * Serialization++    -- * 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).++    -- * 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++    -- ** Language   , ISO639_1   , language   , languageToText   , languageFromText-  -- ** Language Extension++    -- ** Language Extension   , LanguageExtension   , extendedLanguageSubtags   , languageExtensionToText   , languageExtensionFromText-  -- ** Language Script++    -- ** Language Script   , Script   , script   , scriptToText   , scriptFromText-  -- ** Region++    -- ** Region   , Country   , region   , regionToText   , regionFromText-  -- ** Variant++    -- ** Variant   , Variant   , variants   , variantToText   , variantFromText-  -- ** Extension++    -- ** Extension   , Extension   , extensions   , extensionToText   , extensionFromText-  -- ** Private Use++    -- ** Private Use   , PrivateUse   , privateUse   , privateUseToText   , privateUseFromText-  -- * For testing++    -- * 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+  ( unitedKingdomOfGreatBritainAndNorthernIreland+  , unitedStatesOfAmerica+  ) import Data.BCP47.Internal.Arbitrary-  (Arbitrary, arbitrary, choose, elements, listOf, vectorOf)+  ( Arbitrary+  , arbitrary+  , choose+  , elements+  , listOf+  , vectorOf+  ) import Data.BCP47.Internal.Extension import Data.BCP47.Internal.Language import Data.BCP47.Internal.LanguageExtension@@ -99,12 +115,12 @@ import Data.BCP47.Internal.Variant import Data.Bifunctor (first) import Data.Foldable (toList)-import Data.LanguageCodes (ISO639_1(EN, ES, SW))+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 Data.Text (Text, pack) import qualified Data.Text as T import Data.Void (Void) import Text.Megaparsec (Parsec, eof, hidden, many, optional, parse, try)@@ -117,10 +133,9 @@ -- 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-  { language :: ISO639_1 -- ^ The language subtag+data BCP47 = BCP47+  { language :: ISO639_1+  -- ^ The language subtag   , subtags :: Set Subtags   }   deriving stock (Eq, Ord)@@ -131,14 +146,16 @@     oneOrNone f = choose (0, 1) >>= (`vectorOf` (f <$> arbitrary))     manyOf f = listOf (f <$> arbitrary)     regions = [minBound .. maxBound]-    specs = Set.fromList . mconcat <$> sequenceA-      [ manyOf SpecifyLanguageExtension-      , oneOrNone SpecifyScript-      , choose (0, 1) >>= (`vectorOf` (elements $ SpecifyRegion <$> regions))-      , manyOf SpecifyVariant-      , manyOf SpecifyExtension-      , oneOrNone SpecifyPrivateUse-      ]+    specs =+      Set.fromList . mconcat+        <$> sequenceA+          [ manyOf SpecifyLanguageExtension+          , oneOrNone SpecifyScript+          , choose (0, 1) >>= (`vectorOf` (elements $ SpecifyRegion <$> regions))+          , manyOf SpecifyVariant+          , manyOf SpecifyExtension+          , oneOrNone SpecifyPrivateUse+          ]  instance Show BCP47 where   show = T.unpack . toText@@ -148,25 +165,19 @@     Left _ -> []     Right b -> [(b, "")] -instance ToJSON BCP47 where-  toEncoding = toEncoding . toText-  toJSON = toJSON . toText--instance FromJSON BCP47 where-  parseJSON = withText "BCP47" $ either (fail . unpack) pure . 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 b = T.intercalate "-" $ mconcat-  [ [languageToText $ language b]-  , mapMaybe fromSubtags . Set.toList $ subtags b-  , if Set.null (privateUse b) then [] else ["x"]-  , map privateUseToText . Set.toList $ privateUse b-  ]+toText b =+  T.intercalate "-" $+    mconcat+      [ [languageToText $ language b]+      , mapMaybe fromSubtags . Set.toList $ subtags b+      , if Set.null (privateUse b) then [] else ["x"]+      , map privateUseToText . Set.toList $ privateUse b+      ]  where   fromSubtags = \case     SpecifyLanguageExtension x -> Just $ languageExtensionToText x@@ -229,9 +240,8 @@  -- | Produce a list of @(<= priority)@ language tags ----- >>> inits enGBTJP--- [en,en-GB,en-GB-t-jp]---+-- >>> inits <$> fromText (pack "en-GB-t-jp")+-- Right [en,en-GB,en-GB-t-jp] inits :: BCP47 -> [BCP47] inits tag =   map (BCP47 (language tag) . Set.fromList) . List.inits $ toSubtags tag@@ -284,7 +294,6 @@ -- -- >>> fromText $ pack "zh" -- Right zh--- fromText :: Text -> Either Text BCP47 fromText =   first (pack . errorBundlePretty) . parse (parser <* hidden eof) "fromText"@@ -293,24 +302,26 @@ -- -- >>> _example $ pack "en;" -- Right (en,';')--- _example :: Text -> Either Text (BCP47, Char) _example = first (pack . errorBundlePretty) . parse p "example"-  where p = (,) <$> parser <*> char ';'+ where+  p = (,) <$> parser <*> char ';'  parser :: Parsec Void Text BCP47 parser = BCP47 <$> languageP <*> subtagsP  where-  subtagsP = mconcat <$> sequenceA-    [ manyAsSet SpecifyLanguageExtension (try (char '-' *> languageExtensionP))-    , maybe mempty (Set.singleton . SpecifyScript)-      <$> (try (optional $ char '-' *> scriptP) <|> pure Nothing)-    , maybe mempty (Set.singleton . SpecifyRegion)-      <$> (try (optional $ char '-' *> regionP) <|> pure Nothing)-    , manyAsSet SpecifyVariant (try (char '-' *> variantP))-    , manyAsSet SpecifyExtension (try (char '-' *> extensionP))-    , Set.map SpecifyPrivateUse <$> (try (char '-' *> privateUseP) <|> mempty)-    ]+  subtagsP =+    mconcat+      <$> sequenceA+        [ manyAsSet SpecifyLanguageExtension (try (char '-' *> languageExtensionP))+        , maybe mempty (Set.singleton . SpecifyScript)+            <$> (try (optional $ char '-' *> scriptP) <|> pure Nothing)+        , maybe mempty (Set.singleton . SpecifyRegion)+            <$> (try (optional $ char '-' *> regionP) <|> pure Nothing)+        , manyAsSet SpecifyVariant (try (char '-' *> variantP))+        , manyAsSet SpecifyExtension (try (char '-' *> extensionP))+        , Set.map SpecifyPrivateUse <$> (try (char '-' *> privateUseP) <|> mempty)+        ]  manyAsSet :: (Ord b, MonadPlus m) => (a -> b) -> m a -> m (Set b) manyAsSet f p = Set.fromList . map f <$> many p@@ -334,17 +345,3 @@ -- | American English enUS :: BCP47 enUS = mkLocalized EN unitedStatesOfAmerica---- | A nonsense tag @en-t-jp@-enTJP :: BCP47-enTJP = en-  { subtags = Set.insert (SpecifyExtension (Extension (pack "t-jp")))-    $ subtags en-  }---- | A nonsense tag @en-GB-t-jp@-enGBTJP :: BCP47-enGBTJP = enGB-  { subtags = Set.insert (SpecifyExtension (Extension (pack "t-jp")))-    $ subtags enGB-  }

@@ -0,0 +1,39 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.BCP47.Internal.CIText+  ( CIText (..)+  , fromText+  , pack+  , original+  ) where++import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI+import Data.String (IsString)+import Data.Text (Text)+import qualified Data.Text as T++-- | Internal newtype for 'CI Text'+--+-- Constructor is exposed since this is an internal module, but ths+-- interface may change. Module is meant to be imported qualified.+newtype CIText = CIText+  { unCIText :: CI Text+  }+  deriving newtype (Eq, Show, Ord, IsString)++-- | Convert 'Text' to 'CIText'+fromText :: Text -> CIText+fromText = CIText . CI.mk+{-# INLINE fromText #-}++-- | Convert 'String' to 'CIText'+pack :: String -> CIText+pack = fromText . T.pack+{-# INLINE pack #-}++-- | Recover original 'Text'+original :: CIText -> Text+original = CI.original . unCIText+{-# INLINE original #-}

@@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-}  module Data.BCP47.Internal.Extension-  ( Extension(Extension)+  ( Extension (Extension)   , extensionFromText   , extensionToText   , extensionP@@ -11,13 +11,21 @@  import Control.Monad (void, when) import Data.BCP47.Internal.Arbitrary-  (Arbitrary, alphaChar, alphaNumString, arbitrary, choose, suchThat)-import Data.BCP47.Internal.Parser (complete)+  ( Arbitrary+  , alphaChar+  , alphaNumString+  , arbitrary+  , choose+  , suchThat+  )+import Data.BCP47.Internal.CIText (CIText)+import qualified Data.BCP47.Internal.CIText as CI+import Data.BCP47.Internal.Parser (asciiLetterDigit, complete) import Data.Bifunctor (first) import Data.Text (Text, pack) import Data.Void (Void) import Text.Megaparsec (Parsec, count', parse)-import Text.Megaparsec.Char (alphaNumChar, char)+import Text.Megaparsec.Char (char) import Text.Megaparsec.Error (errorBundlePretty)  -- | Extension subtags@@ -26,16 +34,18 @@ -- various applications.  They are intended to identify information that -- is commonly used in association with languages or language tags but -- that is not part of language identification.----newtype Extension = Extension { extensionToText :: Text }+newtype Extension = Extension {unExtension :: CIText}   deriving stock (Show, Eq, Ord) +extensionToText :: Extension -> Text+extensionToText = CI.original . unExtension+ instance Arbitrary Extension where   arbitrary = do     prefix <- alphaChar `suchThat` (`notElem` ['x', 'X'])     len <- choose (2, 8)     chars <- alphaNumString len-    pure . Extension . pack $ prefix : '-' : chars+    pure . Extension . CI.pack $ prefix : '-' : chars  -- | Parse an 'Extension' subtag from 'Text' extensionFromText :: Text -> Either Text Extension@@ -55,11 +65,10 @@ --               / %x61-77             ; a - w --               / %x79-7A             ; y - z -- @@--- extensionP :: Parsec Void Text Extension extensionP = complete $ do-  ext <- alphaNumChar+  ext <- asciiLetterDigit   when (ext `elem` ['x', 'X']) $ fail "private use suffix found"   void $ char '-'-  rest <- count' 2 8 alphaNumChar-  pure . Extension . pack $ ext : '-' : rest+  rest <- count' 2 8 asciiLetterDigit+  pure . Extension . CI.pack $ ext : '-' : rest

@@ -8,17 +8,18 @@   ) where -import Data.BCP47.Internal.Parser (complete)+import Data.BCP47.Internal.Parser (asciiLetter, complete) import Data.Bifunctor (first)+import qualified Data.Char as C import Data.LanguageCodes (ISO639_1, fromChars)-import Data.Text (Text, pack, toLower)+import Data.Text (Text, pack)+import qualified Data.Text as T import Data.Void (Void) import Text.Megaparsec (Parsec, parse)-import Text.Megaparsec.Char (lowerChar) import Text.Megaparsec.Error (errorBundlePretty)  languageToText :: ISO639_1 -> Text-languageToText = toLower . pack . show+languageToText = T.toLower . pack . show  -- | Parse a language subtag from 'Text' languageFromText :: Text -> Either Text ISO639_1@@ -36,8 +37,9 @@ --                / 4ALPHA              ; or reserved for future use --                / 5*8ALPHA            ; or registered language subtag -- @@--- languageP :: Parsec Void Text ISO639_1 languageP = complete $ do-  mCode <- fromChars <$> lowerChar <*> lowerChar+  mCode <- fromChars <$> letter <*> letter   maybe (fail "unknown ISO-639-1 code") pure mCode+ where+  letter = C.toLower <$> asciiLetter

@@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-}  module Data.BCP47.Internal.LanguageExtension-  ( LanguageExtension(LanguageExtension)+  ( LanguageExtension (LanguageExtension)   , languageExtensionFromText   , languageExtensionToText   , languageExtensionP@@ -11,13 +11,15 @@  import Control.Monad (replicateM, void) import Data.BCP47.Internal.Arbitrary (Arbitrary, alphaString, arbitrary)-import Data.BCP47.Internal.Parser (complete)+import Data.BCP47.Internal.CIText (CIText)+import qualified Data.BCP47.Internal.CIText as CI+import Data.BCP47.Internal.Parser (asciiLetter, complete) import Data.Bifunctor (first) import Data.List (intercalate) import Data.Text (Text, pack) import Data.Void (Void) import Text.Megaparsec (Parsec, count, parse)-import Text.Megaparsec.Char (char, letterChar)+import Text.Megaparsec.Char (char) import Text.Megaparsec.Error (errorBundlePretty)  -- | Extended language subtags@@ -25,19 +27,22 @@ -- These are used to identify certain specially selected languages that, for -- various historical and compatibility reasons, are closely identified with or -- tagged using an existing primary language subtag.----newtype LanguageExtension = LanguageExtension { languageExtensionToText :: Text }+newtype LanguageExtension = LanguageExtension {unLanguageExtension :: CIText}   deriving stock (Show, Eq, Ord) +languageExtensionToText :: LanguageExtension -> Text+languageExtensionToText = CI.original . unLanguageExtension+ instance Arbitrary LanguageExtension where   arbitrary = do     components <- replicateM 3 $ alphaString 3-    pure . LanguageExtension $ pack $ intercalate "-" components+    pure $ LanguageExtension $ CI.pack $ intercalate "-" components  -- | Parse a 'LanguageExtension' subtag from 'Text' languageExtensionFromText :: Text -> Either Text LanguageExtension-languageExtensionFromText = first (pack . errorBundlePretty)-  . parse languageExtensionP "languageExtensionFromText"+languageExtensionFromText =+  first (pack . errorBundlePretty)+    . parse languageExtensionP "languageExtensionFromText"  -- | BCP-47 language extension parser --@@ -47,13 +52,12 @@ --  extlang       = 3ALPHA              ; selected ISO 639 codes --                 *2("-" 3ALPHA)      ; permanently reserved -- @@--- languageExtensionP :: Parsec Void Text LanguageExtension languageExtensionP = complete $ do-  iso639 <- count 3 letterChar+  iso639 <- count 3 asciiLetter   void $ char '-'-  c1 <- count 3 letterChar+  c1 <- count 3 asciiLetter   void $ char '-'-  c2 <- count 3 letterChar-  let ext = pack $ mconcat [iso639, "-", c1, "-", c2]+  c2 <- count 3 asciiLetter+  let ext = CI.pack $ mconcat [iso639, "-", c1, "-", c2]   pure $ LanguageExtension ext

@@ -1,12 +1,16 @@ module Data.BCP47.Internal.Parser   ( complete+  , asciiLetterDigit+  , asciiLetter+  , asciiDigit   ) where  import Control.Applicative ((<|>)) import Control.Monad (void)+import Data.Char (ord) import Data.Text (Text) import Data.Void (Void)-import Text.Megaparsec (Parsec, eof, lookAhead, noneOf)+import Text.Megaparsec (Parsec, eof, lookAhead, noneOf, satisfy, (<?>)) import Text.Megaparsec.Char (char)  -- | Ensure a subtag extends to the next '-' or end of input@@ -17,10 +21,45 @@ -- -- The alternative would be to use @'notFollowedBy'@ with knowledge of -- the legal characters in the next valid subtag.--- complete :: Parsec Void Text a -> Parsec Void Text a complete parser =   parser <* lookAhead (void (char '-') <|> eof <|> void (noneOf tagChars))  tagChars :: String tagChars = '-' : ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9']+{-# NOINLINE tagChars #-}++-- | Parse a single case-insensitive ASCII letter or digit+asciiLetterDigit :: Parsec Void Text Char+asciiLetterDigit = satisfy isAsciiLetterDigit <?> "ascii letter or digit"+ where+  isAsciiLetterDigit c = do+    let code = ord c+    isCodeAsciiUpper code || isCodeAsciiLower code || isCodeAsciiDigit code+{-# INLINE asciiLetterDigit #-}++-- | Parse a single case-insensitive ASCII letter+asciiLetter :: Parsec Void Text Char+asciiLetter = satisfy isAsciiLetter <?> "ascii letter"+ where+  isAsciiLetter c = do+    let code = ord c+    isCodeAsciiUpper code || isCodeAsciiLower code+{-# INLINE asciiLetter #-}++-- | Parse a single ASCII digit+asciiDigit :: Parsec Void Text Char+asciiDigit = satisfy (isCodeAsciiDigit . ord) <?> "ascii digit"+{-# INLINE asciiDigit #-}++isCodeAsciiUpper :: Int -> Bool+isCodeAsciiUpper code = ord 'A' <= code && code <= ord 'Z'+{-# INLINE isCodeAsciiUpper #-}++isCodeAsciiLower :: Int -> Bool+isCodeAsciiLower code = ord 'a' <= code && code <= ord 'z'+{-# INLINE isCodeAsciiLower #-}++isCodeAsciiDigit :: Int -> Bool+isCodeAsciiDigit code = ord '0' <= code && code <= ord '9'+{-# INLINE isCodeAsciiDigit #-}

@@ -2,39 +2,48 @@ {-# LANGUAGE OverloadedStrings #-}  module Data.BCP47.Internal.PrivateUse-  ( PrivateUse(PrivateUse)+  ( PrivateUse (PrivateUse)   , privateUseFromText   , privateUseToText   , privateUseP   ) where +import Control.Applicative ((<|>)) import Control.Monad (void) import Data.BCP47.Internal.Arbitrary-  (Arbitrary, alphaNumString, arbitrary, choose)-import Data.BCP47.Internal.Parser (complete)+  ( Arbitrary+  , alphaNumString+  , arbitrary+  , choose+  )+import Data.BCP47.Internal.CIText (CIText)+import qualified Data.BCP47.Internal.CIText as CI+import Data.BCP47.Internal.Parser (asciiLetterDigit, complete) import Data.Bifunctor (first) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text, pack) import Data.Void (Void) import Text.Megaparsec (Parsec, count', parse, some)-import Text.Megaparsec.Char (alphaNumChar, char)+import Text.Megaparsec.Char (char) import Text.Megaparsec.Error (errorBundlePretty)  -- | Private Use subtags -- -- Private use subtags are used to indicate distinctions in language -- that are important in a given context by private agreement.----newtype PrivateUse = PrivateUse { privateUseToText :: Text }+newtype PrivateUse = PrivateUse {unPrivateUse :: CIText}   deriving stock (Show, Eq, Ord) +privateUseToText :: PrivateUse -> Text+privateUseToText = CI.original . unPrivateUse+ instance Arbitrary PrivateUse where   arbitrary = do     len <- choose (1, 8)     chars <- alphaNumString len-    pure . PrivateUse $ pack chars+    pure . PrivateUse $ CI.pack chars  -- | Parse a 'PrivateUse' subtag from 'Text' privateUseFromText :: Text -> Either Text (Set PrivateUse)@@ -46,9 +55,8 @@ -- @@ -- privateuse    = "x" 1*("-" (1*8alphanum)) -- @@--- privateUseP :: Parsec Void Text (Set PrivateUse) privateUseP = complete $ do-  void $ char 'x'-  rest <- some (char '-' *> count' 1 8 alphaNumChar)-  pure $ Set.fromList $ PrivateUse . pack <$> rest+  void $ char 'x' <|> char 'X'+  rest <- some (char '-' *> count' 1 8 asciiLetterDigit)+  pure $ Set.fromList $ PrivateUse . CI.pack <$> rest

@@ -8,12 +8,11 @@  import Control.Applicative ((<|>)) import Country (Country, alphaTwoUpper, decodeAlphaTwo, decodeNumeric)-import Data.BCP47.Internal.Parser (complete)+import Data.BCP47.Internal.Parser (asciiDigit, asciiLetter, complete) import Data.Bifunctor (first)-import Data.Text (Text, pack)+import Data.Text (Text, pack, toUpper) import Data.Void (Void) import Text.Megaparsec (Parsec, count, parse, try, (<?>))-import Text.Megaparsec.Char (digitChar, upperChar) import Text.Megaparsec.Error (errorBundlePretty) import Text.Read (readEither) @@ -22,15 +21,23 @@  -- | Parse a region subtag from 'Text' --+-- >>> regionFromText $ pack "zw"+-- Right zimbabwe+-- -- >>> regionFromText $ pack "ZW" -- Right zimbabwe --+-- >>> regionFromText $ pack "Zw"+-- Right zimbabwe+--+-- >>> regionFromText $ pack "zW"+-- Right zimbabwe+-- -- >>> regionFromText $ pack "012" -- Right algeria -- -- >>> regionFromText $ pack "asdf"--- Left "regionFromText:1:1:\n  |\n1 | asdf\n  | ^\nunexpected 'a'\nexpecting 2 or 3 character country code\n"---+-- Left "regionFromText:1:3:\n  |\n1 | asdf\n  |   ^\nunexpected 'd'\nexpecting 2 or 3 character country code\n" regionFromText :: Text -> Either Text Country regionFromText =   first (pack . errorBundlePretty) . parse regionP "regionFromText"@@ -41,18 +48,21 @@ -- region        = 2ALPHA              ; ISO 3166-1 code --               / 3DIGIT              ; UN M.49 code -- @@--- regionP :: Parsec Void Text Country-regionP = complete (try alpha2 <|> num3 <?> "2 or 3 character country code")+regionP =+  try (complete asciiLetter2)+    <|> try (complete num3)+    <?> "2 or 3 character country code"  where-  alpha2 =-    maybe (fail "Invalid 2 character country code") pure-      . decodeAlphaTwo-      . pack-      =<< count 2 upperChar-  num3 =-    maybe (fail "Invalid 3 character country code") pure-      . decodeNumeric-      =<< either fail pure-      . readEither-      =<< count 3 digitChar+  asciiLetter2 = do+    code <- pack <$> count 2 asciiLetter+    let region = decodeAlphaTwo $ toUpper code+    unwrap "Invalid 2 character country code" region++  num3 = do+    code <- count 3 asciiDigit+    region <- decodeNumeric <$> either fail pure (readEither code)+    unwrap "Invalid 3 character country code" region++  unwrap :: String -> Maybe a -> Parsec Void Text a+  unwrap message = maybe (fail message) pure

@@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-}  module Data.BCP47.Internal.Script-  ( Script(Script)+  ( Script (Script)   , scriptFromText   , scriptToText   , scriptP@@ -10,12 +10,13 @@ where  import Data.BCP47.Internal.Arbitrary (Arbitrary, alphaString, arbitrary)-import Data.BCP47.Internal.Parser (complete)+import Data.BCP47.Internal.CIText (CIText)+import qualified Data.BCP47.Internal.CIText as CI+import Data.BCP47.Internal.Parser (asciiLetter, complete) import Data.Bifunctor (first) import Data.Text (Text, pack) import Data.Void (Void) import Text.Megaparsec (Parsec, count, parse)-import Text.Megaparsec.Char (letterChar) import Text.Megaparsec.Error (errorBundlePretty)  -- | Script subtags@@ -23,12 +24,14 @@ -- Script subtags are used to indicate the script or writing system -- variations that distinguish the written forms of a language or its -- dialects.----newtype Script = Script { scriptToText :: Text }+newtype Script = Script {unScript :: CIText}   deriving stock (Show, Eq, Ord) +scriptToText :: Script -> Text+scriptToText = CI.original . unScript+ instance Arbitrary Script where-  arbitrary = Script . pack <$> alphaString 4+  arbitrary = Script . CI.pack <$> alphaString 4  -- | Parse a 'Script' subtag from 'Text' scriptFromText :: Text -> Either Text Script@@ -40,6 +43,5 @@ -- @@ --  script        = 4ALPHA              ; ISO 15924 code -- @@--- scriptP :: Parsec Void Text Script-scriptP = complete $ Script . pack <$> count 4 letterChar+scriptP = complete $ Script . CI.pack <$> count 4 asciiLetter

@@ -2,7 +2,7 @@ {-# LANGUAGE DerivingStrategies #-}  module Data.BCP47.Internal.Subtags-  ( Subtags(..)+  ( Subtags (..)   ) where  import Data.BCP47.Internal.Extension@@ -26,13 +26,12 @@   deriving stock (Show, Eq, Ord, Generic)  instance Arbitrary Subtags where-  arbitrary = oneof-    [ SpecifyLanguageExtension <$> arbitrary-    , SpecifyScript <$> arbitrary-    , SpecifyRegion <$> genericArbitrary-    , SpecifyVariant <$> arbitrary-    , SpecifyExtension <$> arbitrary-    , SpecifyPrivateUse <$> arbitrary-    ]--+  arbitrary =+    oneof+      [ SpecifyLanguageExtension <$> arbitrary+      , SpecifyScript <$> arbitrary+      , SpecifyRegion <$> genericArbitrary+      , SpecifyVariant <$> arbitrary+      , SpecifyExtension <$> arbitrary+      , SpecifyPrivateUse <$> arbitrary+      ]

@@ -2,22 +2,29 @@ {-# LANGUAGE OverloadedStrings #-}  module Data.BCP47.Internal.Variant-  ( Variant(Variant)+  ( Variant (Variant)   , variantFromText   , variantToText   , variantP   )-  where+where  import Control.Applicative ((<|>)) import Data.BCP47.Internal.Arbitrary-  (Arbitrary, alphaNumString, arbitrary, choose, numChar, oneof)-import Data.BCP47.Internal.Parser (complete)+  ( Arbitrary+  , alphaNumString+  , arbitrary+  , choose+  , numChar+  , oneof+  )+import Data.BCP47.Internal.CIText (CIText)+import qualified Data.BCP47.Internal.CIText as CI+import Data.BCP47.Internal.Parser (asciiDigit, asciiLetterDigit, complete) import Data.Bifunctor (first) import Data.Text (Text, pack) import Data.Void (Void) import Text.Megaparsec (Parsec, count, count', parse, try)-import Text.Megaparsec.Char (alphaNumChar, digitChar) import Text.Megaparsec.Error (errorBundlePretty)  -- | BCP-47 variant parser@@ -26,17 +33,16 @@ -- variant       = 5*8alphanum         ; registered variants --               / (DIGIT 3alphanum) -- @@--- variantP :: Parsec Void Text Variant variantP =-  complete-    $ Variant-    . pack-    <$> (try (count' 5 8 alphaNumChar) <|> digitPrefixed)+  complete $+    Variant+      . CI.pack+      <$> (try (count' 5 8 asciiLetterDigit) <|> digitPrefixed)  where   digitPrefixed = do-    x <- digitChar-    xs <- count 3 alphaNumChar+    x <- asciiDigit+    xs <- count 3 asciiLetterDigit     pure $ x : xs  -- | Variant subtags@@ -44,21 +50,23 @@ -- Variant subtags are used to indicate additional, well-recognized -- variations that define a language or its dialects that are not -- covered by other available subtags.----newtype Variant = Variant { variantToText :: Text }+newtype Variant = Variant {unVariant :: CIText}   deriving stock (Show, Eq, Ord) +variantToText :: Variant -> Text+variantToText = CI.original . unVariant+ instance Arbitrary Variant where   arbitrary = oneof [alphaNum, digitPrefixed]    where     alphaNum = do       len <- choose (5, 8)       chars <- alphaNumString len-      pure . Variant $ pack chars+      pure . Variant $ CI.pack chars     digitPrefixed = do       prefix <- numChar       chars <- alphaNumString 3-      pure . Variant $ pack $ prefix : chars+      pure . Variant $ CI.pack $ prefix : chars  -- | Parse a 'Variant' subtag from 'Text' variantFromText :: Text -> Either Text Variant

@@ -2,7 +2,6 @@ -- -- This structure supports collection and lookup of language tagged values. Its -- semantics are based on those defined in the BCP 47 specification.--- module Data.BCP47.Trie   ( Trie   , fromList@@ -32,7 +31,6 @@ -- or 'de-CH' but never content with the tag 'de-CH-1996'." -- -- https://tools.ietf.org/html/bcp47#page-2-12--- lookup :: BCP47 -> Trie a -> Maybe a lookup tag trie = lookup2 tag =<< Map.lookup (language tag) (unLanguage trie) 

@@ -1,8 +1,9 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-}  module Data.BCP47.Trie.Internal-  ( Trie(..)+  ( Trie (..)   , fromList   , fromNonEmpty   , singleton@@ -10,32 +11,34 @@   , unionWith   , unionUsing   , mapMaybe-  , Trie2(..)-  , Subtags(..)+  , Trie2 (..)+  , Subtags (..)   , singleton2   , lookup2   , match2-  , union2   , union2Using   , fromSubtags   , mapMaybe2   )-  where+where +#if MIN_VERSION_base(4,18,0)+import Control.Applicative ((<|>))+#else import Control.Applicative (liftA2, (<|>))+#endif import Data.BCP47 import Data.BCP47.Internal.Subtags import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Map (Map) import qualified Data.Map as Map-import Data.Monoid (Last(Last, getLast))+import Data.Monoid (Last (Last, getLast)) import Test.QuickCheck.Arbitrary-import Test.QuickCheck.Modifiers (NonEmptyList(getNonEmpty))+import Test.QuickCheck.Modifiers (NonEmptyList (getNonEmpty))  -- | A trie mapping 'BCP47' tags to values-newtype Trie a-  = Trie { unLanguage :: Map ISO639_1 (Trie2 a)}+newtype Trie a = Trie {unLanguage :: Map ISO639_1 (Trie2 a)}   deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable)  instance Semigroup a => Semigroup (Trie a) where@@ -116,9 +119,6 @@   go :: [Subtags] -> Trie2 a -> Maybe a   go [] (Trie2 mVal _) = mVal   go (p : ps) (Trie2 _ children) = go ps =<< Map.lookup p children--union2 :: Trie2 a -> Trie2 a -> Trie2 a-union2 = union2Using (<|>)  union2Using :: (Maybe a -> Maybe a -> Maybe a) -> Trie2 a -> Trie2 a -> Trie2 a union2Using f (Trie2 x xs) (Trie2 y ys) =

@@ -1,3 +1,4 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -5,15 +6,14 @@   ( spec   ) where -import Prelude hiding (lookup)+import TestImport hiding (lookup)  import Data.BCP47 import Data.BCP47.Trie import Data.Foldable import qualified Data.List as List import qualified Data.Maybe as Maybe-import Test.Hspec-import Test.QuickCheck+import qualified Data.Text as T  catMaybes :: Trie (Maybe a) -> Maybe (Trie a) catMaybes = mapMaybe id@@ -104,6 +104,13 @@       let Just trie = fromList [(en, "color"), (enGB, "colour")]       lookup enGBTJP trie `shouldBe` Just "colour" +    it "lookups case-insensitively" $ property $ \tag -> do+      let tagText = toText tag+      let Right upper = fromText $ T.toUpper tagText+      let Right lower = fromText $ T.toLower tagText+      let trie = singleton upper "color"+      lookup lower trie `shouldBe` Just "color"+   describe "match" $ do     it "should always match a path it inserts" $ property $ \tag ->       match tag (singleton tag "string") `shouldBe` Just "string"@@ -135,3 +142,7 @@     it "matches a deep relevant match" $ do       let Just trie = fromList [(en, "color"), (enGB, "colour")]       match enGBTJP trie `shouldBe` Nothing++    it "matches case-insensitively" $ do+      let Just trie = fromList [(enTJPUpper, "color"), (enGBTJPUpper, "color")]+      match enTJP trie `shouldBe` Just "color"

@@ -1,31 +1,31 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.BCP47Spec   ( spec   ) where +import TestImport+ import Country.Identifier (china)-import Data.Aeson (decode, encode) import Data.BCP47 import Data.BCP47.Internal.Extension import Data.BCP47.Internal.LanguageExtension import Data.BCP47.Internal.PrivateUse import Data.BCP47.Internal.Script import Data.BCP47.Internal.Variant-import Data.LanguageCodes (ISO639_1(ZH))+import Data.Either (isRight)+import Data.LanguageCodes (ISO639_1 (ZH)) import qualified Data.Set as Set-import Data.Text (unpack)-import Test.Hspec-import Test.QuickCheck (property)-import Text.Read (readMaybe)  spec :: Spec spec = do   describe "fromText" $ do     it "parses all components" $ do-      lng <- either (ioError . userError . unpack) pure-        $ fromText "zh-abc-def-zxy-Hant-CN-1967-y-extensi-x-private1-private2"+      lng <-+        fromTextThrows+          "zh-abc-def-zxy-Hant-CN-1967-y-extensi-x-private1-private2"       language lng `shouldBe` ZH       extendedLanguageSubtags lng         `shouldBe` Set.singleton (LanguageExtension "abc-def-zxy")@@ -38,7 +38,7 @@      it "only parses complete subtags" $ do       -- Specifically, the region CN should not be parsed out of the variant CNUVWXYX-      lng <- either (ioError . userError . unpack) pure $ fromText "zh-CNUVWXYX"+      lng <- fromTextThrows "zh-CNUVWXYX"       language lng `shouldBe` ZH       extendedLanguageSubtags lng `shouldBe` Set.empty       script lng `shouldBe` Nothing@@ -54,5 +54,54 @@   describe "Read/Show" . it "can roundtrip" . property $ \tag ->     readMaybe (show @BCP47 tag) `shouldBe` Just tag -  describe "ToJSON/FromJSON" . it "roundtrips" . property $ \x ->-    decode (encode @BCP47 x) `shouldBe` Just x+  describe "Eq" $ do+    it "compares equal with different casing" $ do+      lower <-+        fromTextThrows+          "zh-abc-def-zxy-hant-cn-1967-y-extensi-x-private1-private2"+      upper <-+        fromTextThrows+          "ZH-ABC-DEF-ZXY-HANT-CN-1967-Y-EXTENSI-X-PRIVATE1-PRIVATE2"+      upper `shouldBe` lower++  describe "Regression tests" $ do+    -- We used to require Region to be uppercase (incorrectly)+    it "accepts en-gb" $ fromText "en-gb" `shouldBe` Right enGB++  describe "Known bugs" $ do+    -- Per https://datatracker.ietf.org/doc/html/rfc5646#section-2.2.4+    -- we should accept e.g. 419 (Latin America and the Caribbean), but+    -- not 3-digit M49 codes for regions that already have a 2-letter+    -- code, e.g. 012 (Algeria, DZ)+    --+    -- The country library we use only recognizes 3-digit M49 codes for+    -- countries, so it rejects other kinds of regions.+    it "accepts es-419" $ do+      pendingWith "country library does not recognize non-country M49 codes"+      let result = fromText "es-419"+      result `shouldSatisfy` isRight++    -- Per https://www.iso.org/obp/ui/#iso:code:3166:TP+    -- East Timor changed to Timor-Leste, but TP is still reserved+    -- until 2052-05.+    --+    -- The country library we use only recognizes Timor-Leste (TL),+    -- so it rejects TP.+    it "accepts en-TP" $ do+      pendingWith "country library does not recognize TP anymore"+      let result = fromText "es-TP"+      result `shouldSatisfy` isRight++    -- Per https://datatracker.ietf.org/doc/html/rfc5646#section-2.2.2+    -- Languages encompassed by certain macrolanguages can be+    -- registered as extended language subtags. These may be represented+    -- either with the lone subtag for the encompassed language, e.g.+    -- cmn for Mandarin, or with a language-extlang combination, e.g.+    -- zh-cmn. The first option is preferred.+    --+    -- We currently don't support this because we always expect a+    -- leading ISO-639-1 code.+    it "accepts cnm" $ do+      pendingWith "Parser incorrectly requires a leading ISO-639-1 code"+      let result = fromText "cnm"+      result `shouldSatisfy` isRight

@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++module TestImport+  ( module X+  , enTJP+  , enTJPUpper+  , enGBTJP+  , enGBTJPUpper+  , unsafeFromText+  , fromTextThrows+  ) where++import Prelude as X++import Control.Exception (throwIO)+import Control.Monad.IO.Class (MonadIO(..))+import Data.BCP47 (BCP47, fromText)+import Data.Text (Text, unpack)+import Test.Hspec as X+import Test.QuickCheck as X+import Text.Read as X (readMaybe)++-- | A nonsense tag @en-t-jp@+enTJP :: BCP47+enTJP = unsafeFromText "en-t-jp"++-- | A nonsense tag @en-T-jp@+enTJPUpper :: BCP47+enTJPUpper = unsafeFromText "en-T-jp"++-- | A nonsense tag @en-GB-t-jp@+enGBTJP :: BCP47+enGBTJP = unsafeFromText "en-GB-t-jp"++-- | A nonsense tag @en-GB-t-jp@+enGBTJPUpper :: BCP47+enGBTJPUpper = unsafeFromText "en-GB-t-jp"++-- | Parse 'BCP47' or crash with pure error+unsafeFromText :: HasCallStack => Text -> BCP47+unsafeFromText = either (error . unpack) id . fromText++-- | Parse 'BCP47' or throw an IO error+fromTextThrows :: MonadIO m => Text -> m BCP47+fromTextThrows = either (liftIO . throwIO . userError . unpack) pure . fromText