packages feed

bcp47 (empty) → 0.1.0.0

raw patch · 22 files changed

+1263/−0 lines, 22 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, bcp47, containers, country, doctest, generic-arbitrary, hspec, iso639, megaparsec, text

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for bcp47++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright 2018 Freckle++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies+of the Software, and to permit persons to whom the Software is furnished to do+so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,6 @@+# [BCP-47](https://tools.ietf.org/html/bcp47)++[![CircleCI](https://circleci.com/gh/freckle/bcp47.svg?style=svg)](https://circleci.com/gh/freckle/bcp47)++Language tags for use in cases where it is desirable to indicate the language+used in an information object.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bcp47.cabal view
@@ -0,0 +1,101 @@+cabal-version: 1.12+name: bcp47+version: 0.1.0.0+license: MIT+license-file: LICENSE+copyright: 2019 Freckle Education+maintainer: engineering@freckle.com+author: Evan Rutledge Borden+homepage: https://github.com/freckle/bcp47#readme+bug-reports: https://github.com/freckle/bcp47/issues+synopsis: Language tags as specified by BCP 47+description:+    /Language tags for use in cases where it is desirable to indicate the/+    /language used in an information object./+    .+    / - /<https://tools.ietf.org/html/bcp47>+    .+    This package exposes a language tag data type 'BCP47' and a 'Trie' data+    structure for collecting and querying information that varies based on+    language tag.+    .+    > import Data.BCP47 (en, enGB, sw)+    > import Data.BCP47.Trie (Trie, fromList, lookup)+    >+    > color :: Trie Text+    > color = fromList [(en, "color"), (sw, "rangi")]+    >+    > main = do+    >   print $ match en color -- Just "color"+    >   print $ match enGB color -- Nothing+    >   print $ lookup enGB color -- Just "color"+category: Data, Data Structures+build-type: Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+    type: git+    location: https://github.com/freckle/bcp47++library+    exposed-modules:+        Data.BCP47+        Data.BCP47.Internal.Arbitrary+        Data.BCP47.Internal.Extension+        Data.BCP47.Internal.Language+        Data.BCP47.Internal.LanguageExtension+        Data.BCP47.Internal.Parser+        Data.BCP47.Internal.PrivateUse+        Data.BCP47.Internal.Region+        Data.BCP47.Internal.Script+        Data.BCP47.Internal.Subtags+        Data.BCP47.Internal.Variant+        Data.BCP47.Trie+        Data.BCP47.Trie.Internal+    hs-source-dirs: library+    other-modules:+        Paths_bcp47+    default-language: Haskell2010+    build-depends:+        QuickCheck >=2.13.2 && <2.14,+        aeson >=1.4.4.0 && <1.5,+        base >=4.7 && <5,+        containers >=0.6.0.1 && <0.7,+        country >=0.1.6 && <0.2,+        generic-arbitrary >=0.1.0 && <0.2,+        iso639 >=0.1.0.3 && <0.2,+        megaparsec >=7.0.5 && <7.1,+        text >=1.2.3.1 && <1.3++test-suite doctest+    type: exitcode-stdio-1.0+    main-is: Main.hs+    hs-source-dirs: doctest+    other-modules:+        Paths_bcp47+    default-language: Haskell2010+    build-depends:+        base >=4.7 && <5,+        doctest >=0.16.1 && <0.17++test-suite spec+    type: exitcode-stdio-1.0+    main-is: Main.hs+    hs-source-dirs: tests+    other-modules:+        Data.BCP47.TrieSpec+        Data.BCP47Spec+        Paths_bcp47+    default-language: Haskell2010+    build-depends:+        QuickCheck >=2.13.2 && <2.14,+        aeson >=1.4.4.0 && <1.5,+        base >=4.7 && <5,+        bcp47 -any,+        containers >=0.6.0.1 && <0.7,+        country >=0.1.6 && <0.2,+        hspec >=2.7.1 && <2.8,+        iso639 >=0.1.0.3 && <0.2,+        text >=1.2.3.1 && <1.3
+ doctest/Main.hs view
@@ -0,0 +1,11 @@+module Main+  ( main+  )+where++import Prelude++import Test.DocTest++main :: IO ()+main = doctest ["library"]
+ library/Data/BCP47.hs view
@@ -0,0 +1,339 @@+{-# 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+  -- * 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 (Country)+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+  { language :: ISO639_1 -- ^ The language subtag+  , subtags :: Set Subtags+  }+  deriving (Eq, Ord)++instance Arbitrary BCP47 where+  arbitrary = BCP47 <$> elements [EN, ES] <*> specs+   where+    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+      ]++instance Show BCP47 where+  show = T.unpack . toText++instance Read BCP47 where+  readsPrec _ s = case fromText $ T.pack s of+    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+  ]+ where+  fromSubtags = \case+    SpecifyLanguageExtension x -> Just $ languageExtensionToText x+    SpecifyScript x -> Just $ scriptToText x+    SpecifyRegion x -> Just $ regionToText x+    SpecifyVariant x -> Just $ variantToText x+    SpecifyExtension x -> Just $ extensionToText x+    SpecifyPrivateUse _ -> Nothing++-- | Look up all language extension subtags+extendedLanguageSubtags :: BCP47 -> Set LanguageExtension+extendedLanguageSubtags = asSet $ \case+  SpecifyLanguageExtension x -> Just x+  _otherwise -> Nothing++-- | Look up the script subtag+script :: BCP47 -> Maybe Script+script = headMay . mapMaybe f . Set.toList . subtags+ where+  f = \case+    SpecifyScript x -> Just x+    _otherwise -> Nothing++-- | Look up the region subtag+region :: BCP47 -> Maybe Country+region = headMay . mapMaybe f . Set.toList . subtags+ where+  f = \case+    SpecifyRegion x -> Just x+    _otherwise -> Nothing++-- | Look up all variant subtags+variants :: BCP47 -> Set Variant+variants = asSet $ \case+  SpecifyVariant x -> Just x+  _otherwise -> Nothing++-- | Look up all extension subtags+extensions :: BCP47 -> Set Extension+extensions = asSet $ \case+  SpecifyExtension x -> Just x+  _otherwise -> Nothing++-- | Look up all private use subtags+privateUse :: BCP47 -> Set PrivateUse+privateUse = asSet $ \case+  SpecifyPrivateUse x -> Just x+  _otherwise -> Nothing++asSet :: Ord a => (Subtags -> Maybe a) -> BCP47 -> Set a+asSet f = Set.fromList . mapMaybe f . Set.toList . subtags++headMay :: [x] -> Maybe x+headMay [] = Nothing+headMay (x : _) = Just x++-- | Convert tag to list of subtags+toSubtags :: BCP47 -> [Subtags]+toSubtags tag = toList $ subtags tag++-- | Produce a list of @(<= priority)@ language tags+--+-- >>> inits enGBTJP+-- [en,en-GB,en-GB-t-jp]+--+inits :: BCP47 -> [BCP47]+inits tag =+  map (BCP47 (language tag) . Set.fromList) . List.inits $ toSubtags tag++-- | Construct a simple language tag+mkLanguage :: ISO639_1 -> BCP47+mkLanguage lang = BCP47 lang mempty++-- | Construct a localized tag+mkLocalized :: ISO639_1 -> Country -> BCP47+mkLocalized lang locale = BCP47 lang . Set.singleton $ SpecifyRegion 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 = first (pack . errorBundlePretty) . parse parser "fromText"++parser :: Parsec Void Text BCP47+parser = BCP47 <$> languageP <*> subtagsP <* hidden eof+ 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)+    ]++manyAsSet :: (Ord b, MonadPlus m) => (a -> b) -> m a -> m (Set b)+manyAsSet f p = Set.fromList . map f <$> many p++-- | Spanish+es :: BCP47+es = mkLanguage ES++-- | English+en :: BCP47+en = mkLanguage EN++-- | Swahili+sw :: BCP47+sw = mkLanguage SW++-- | British English+enGB :: BCP47+enGB = mkLocalized EN unitedKingdomOfGreatBritainAndNorthernIreland++-- | 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+  }
+ library/Data/BCP47/Internal/Arbitrary.hs view
@@ -0,0 +1,50 @@+module Data.BCP47.Internal.Arbitrary+  ( Arbitrary+  , arbitrary+  , alphaString+  , alphaNumString+  , alphaChar+  , numChar+  , elements+  , choose+  , oneof+  , suchThat+  , listOf+  , vectorOf+  ) where++import Test.QuickCheck+  ( Arbitrary+  , Gen+  , arbitrary+  , choose+  , elements+  , listOf+  , oneof+  , suchThat+  , vectorOf+  )++numChar :: Gen Char+numChar = elements numChars++alphaNumString :: Int -> Gen String+alphaNumString n = vectorOf n alphaNumChar++alphaString :: Int -> Gen String+alphaString n = vectorOf n alphaChar++alphaNumChar :: Gen Char+alphaNumChar = elements alphaNumChars++alphaChar :: Gen Char+alphaChar = elements alphaChars++alphaNumChars :: String+alphaNumChars = alphaChars ++ numChars++alphaChars :: String+alphaChars = ['a' .. 'z'] ++ ['A' .. 'Z']++numChars :: String+numChars = ['0' .. '9']
+ library/Data/BCP47/Internal/Extension.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.BCP47.Internal.Extension+  ( Extension(Extension)+  , extensionFromText+  , extensionToText+  , extensionP+  )+where++import Control.Monad (void, when)+import Data.BCP47.Internal.Arbitrary+  (Arbitrary, alphaChar, alphaNumString, arbitrary, choose, suchThat)+import Data.BCP47.Internal.Parser (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.Error (errorBundlePretty)++-- | Extension subtags+--+-- Extensions provide a mechanism for extending language tags for use in+-- 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 }+  deriving (Show, Eq, Ord)++instance Arbitrary Extension where+  arbitrary = do+    prefix <- alphaChar `suchThat` (`notElem` ['x', 'X'])+    len <- choose (2,8)+    chars <- alphaNumString len+    pure . Extension . pack $ prefix : '-' : chars++-- | Parse an 'Extension' subtag from 'Text'+extensionFromText :: Text -> Either Text Extension+extensionFromText =+  first (pack . errorBundlePretty) . parse extensionP "extensionFromText"++-- | BCP-47 extension parser+--+-- @@+-- extension     = singleton 1*("-" (2*8alphanum))+--                                     ; Single alphanumerics+--                                     ; "x" reserved for private use+--+-- singleton     = DIGIT               ; 0 - 9+--               / %x41-57             ; A - W+--               / %x59-5A             ; Y - Z+--               / %x61-77             ; a - w+--               / %x79-7A             ; y - z+-- @@+--+extensionP :: Parsec Void Text Extension+extensionP = complete $ do+  ext <- alphaNumChar+  when (ext `elem` ['x', 'X']) $ fail "private use suffix found"+  void $ char '-'+  rest <- count' 2 8 alphaNumChar+  pure . Extension . pack $ ext : '-' : rest
+ library/Data/BCP47/Internal/Language.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.BCP47.Internal.Language+  ( ISO639_1+  , languageFromText+  , languageToText+  , languageP+  )+where++import Data.BCP47.Internal.Parser (complete)+import Data.Bifunctor (first)+import Data.LanguageCodes (ISO639_1, fromChars)+import Data.Text (Text, pack, toLower)+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++-- | Parse a language subtag from 'Text'+languageFromText :: Text -> Either Text ISO639_1+languageFromText =+  first (pack . errorBundlePretty) . parse languageP "languageFromText"++-- | BCP-47 language parser+--+-- This only implements the ISO 639 portion of the grammar.+--+-- @@+--  language      = 2*3ALPHA            ; shortest ISO 639 code+--                  ["-" extlang]       ; sometimes followed by+--                                      ; extended language subtags+--                / 4ALPHA              ; or reserved for future use+--                / 5*8ALPHA            ; or registered language subtag+-- @@+--+languageP :: Parsec Void Text ISO639_1+languageP = complete $ do+  mCode <- fromChars <$> lowerChar <*> lowerChar+  maybe (fail "unknown ISO-639-1 code") pure mCode
+ library/Data/BCP47/Internal/LanguageExtension.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.BCP47.Internal.LanguageExtension+  ( LanguageExtension(LanguageExtension)+  , languageExtensionFromText+  , languageExtensionToText+  , languageExtensionP+  )+where++import Control.Monad (replicateM, void)+import Data.BCP47.Internal.Arbitrary (Arbitrary, alphaString, arbitrary)+import Data.BCP47.Internal.Parser (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.Error (errorBundlePretty)++-- | Extended language subtags+--+-- 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 }+  deriving (Show, Eq, Ord)++instance Arbitrary LanguageExtension where+  arbitrary = do+    components <- replicateM 3 $ alphaString 3+    pure . LanguageExtension $ pack $ intercalate "-" components++-- | Parse a 'LanguageExtension' subtag from 'Text'+languageExtensionFromText :: Text -> Either Text LanguageExtension+languageExtensionFromText = first (pack . errorBundlePretty)+  . parse languageExtensionP "languageExtensionFromText"++-- | BCP-47 language extension parser+--+-- This only implements the ISO 639 portion of the ISO.+--+-- @@+--  extlang       = 3ALPHA              ; selected ISO 639 codes+--                 *2("-" 3ALPHA)      ; permanently reserved+-- @@+--+languageExtensionP :: Parsec Void Text LanguageExtension+languageExtensionP = complete $ do+  iso639 <- count 3 letterChar+  void $ char '-'+  c1 <- count 3 letterChar+  void $ char '-'+  c2 <- count 3 letterChar+  let ext = pack $ mconcat [iso639, "-", c1, "-", c2]+  pure $ LanguageExtension ext
+ library/Data/BCP47/Internal/Parser.hs view
@@ -0,0 +1,22 @@+module Data.BCP47.Internal.Parser+  ( complete+  ) where++import Control.Applicative ((<|>))+import Control.Monad (void)+import Data.Text (Text)+import Data.Void (Void)+import Text.Megaparsec (Parsec, eof, lookAhead)+import Text.Megaparsec.Char (char)++-- | Ensure a subtag extends to the next '-' or end of input+--+-- Used for subtags that can match some prefix of another subtag.+-- For example, a @'Script'@ or @'Region'@ can accidentally be parsed+-- from the prefix of a @'Variant'@+--+-- 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)
+ library/Data/BCP47/Internal/PrivateUse.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.BCP47.Internal.PrivateUse+  ( PrivateUse(PrivateUse)+  , privateUseFromText+  , privateUseToText+  , privateUseP+  )+where++import Control.Monad (void)+import Data.BCP47.Internal.Arbitrary+  (Arbitrary, alphaNumString, arbitrary, choose)+import Data.BCP47.Internal.Parser (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.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 }+  deriving (Show, Eq, Ord)++instance Arbitrary PrivateUse where+  arbitrary = do+    len <- choose (1,8)+    chars <- alphaNumString len+    pure . PrivateUse $ pack chars++-- | Parse a 'PrivateUse' subtag from 'Text'+privateUseFromText :: Text -> Either Text (Set PrivateUse)+privateUseFromText =+  first (pack . errorBundlePretty) . parse privateUseP "privateUseFromText"++-- | BCP-47 private use parser+--+-- @@+-- 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
+ library/Data/BCP47/Internal/Region.hs view
@@ -0,0 +1,58 @@+module Data.BCP47.Internal.Region+  ( Country+  , regionToText+  , regionFromText+  , regionP+  )+where++import Control.Applicative ((<|>))+import Country (Country, alphaTwoUpper, decodeAlphaTwo, decodeNumeric)+import Data.BCP47.Internal.Parser (complete)+import Data.Bifunctor (first)+import Data.Text (Text, pack)+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)++regionToText :: Country -> Text+regionToText = alphaTwoUpper++-- | Parse a region subtag from 'Text'+--+-- >>> 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"+--+regionFromText :: Text -> Either Text Country+regionFromText =+  first (pack . errorBundlePretty) . parse regionP "regionFromText"++-- | BCP-47 region parser+--+-- @@+-- 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")+ 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
+ library/Data/BCP47/Internal/Script.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.BCP47.Internal.Script+  ( Script(Script)+  , scriptFromText+  , scriptToText+  , scriptP+  )+where++import Data.BCP47.Internal.Arbitrary (Arbitrary, alphaString, arbitrary)+import Data.BCP47.Internal.Parser (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+--+-- 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 }+  deriving (Show, Eq, Ord)++instance Arbitrary Script where+  arbitrary = Script . pack <$> alphaString 4++-- | Parse a 'Script' subtag from 'Text'+scriptFromText :: Text -> Either Text Script+scriptFromText =+  first (pack . errorBundlePretty) . parse scriptP "scriptFromText"++-- | BCP-47 script parser+--+-- @@+--  script        = 4ALPHA              ; ISO 15924 code+-- @@+--+scriptP :: Parsec Void Text Script+scriptP = complete $ Script . pack <$> count 4 letterChar
+ library/Data/BCP47/Internal/Subtags.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DeriveGeneric #-}++module Data.BCP47.Internal.Subtags+  ( Subtags(..)+  ) where++import Data.BCP47.Internal.Extension+import Data.BCP47.Internal.LanguageExtension+import Data.BCP47.Internal.PrivateUse+import Data.BCP47.Internal.Region+import Data.BCP47.Internal.Script+import Data.BCP47.Internal.Variant+import GHC.Generics (Generic)+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Arbitrary.Generic+import Test.QuickCheck.Gen (oneof)++data Subtags+  = SpecifyLanguageExtension LanguageExtension+  | SpecifyScript Script+  | SpecifyRegion Country+  | SpecifyVariant Variant+  | SpecifyExtension Extension+  | SpecifyPrivateUse PrivateUse+  deriving (Show, Eq, Ord, Generic)++instance Arbitrary Subtags where+  arbitrary = oneof+    [ SpecifyLanguageExtension <$> arbitrary+    , SpecifyScript <$> arbitrary+    , SpecifyRegion <$> genericArbitrary+    , SpecifyVariant <$> arbitrary+    , SpecifyExtension <$> arbitrary+    , SpecifyPrivateUse <$> arbitrary+    ]++
+ library/Data/BCP47/Internal/Variant.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.BCP47.Internal.Variant+  ( Variant(Variant)+  , variantFromText+  , variantToText+  , variantP+  )+  where++import Control.Applicative ((<|>))+import Data.BCP47.Internal.Arbitrary+  (Arbitrary, alphaNumString, arbitrary, choose, numChar, oneof)+import Data.BCP47.Internal.Parser (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+--+-- @@+-- variant       = 5*8alphanum         ; registered variants+--               / (DIGIT 3alphanum)+-- @@+--+variantP :: Parsec Void Text Variant+variantP =+  complete+    $ Variant+    . pack+    <$> (try (count' 5 8 alphaNumChar) <|> digitPrefixed)+ where+  digitPrefixed = do+    x <- digitChar+    xs <- count 3 alphaNumChar+    pure $ x : xs++-- | Variant subtags+--+-- 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 }+  deriving (Show, Eq, Ord)++instance Arbitrary Variant where+  arbitrary = oneof [alphaNum, digitPrefixed]+    where+      alphaNum = do+        len <- choose (5,8)+        chars <- alphaNumString len+        pure . Variant $ pack chars+      digitPrefixed = do+        prefix <- numChar+        chars <- alphaNumString 3+        pure . Variant $ pack $ prefix : chars++-- | Parse a 'Variant' subtag from 'Text'+variantFromText :: Text -> Either Text Variant+variantFromText =+  first (pack . errorBundlePretty) . parse variantP "variantFromText"
+ library/Data/BCP47/Trie.hs view
@@ -0,0 +1,40 @@+-- | A trie like data structure for defining maps from 'BCP47' tags to values.+--+-- 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+  , singleton+  , lookup+  , match+  , elem+  , union+  , unionWith+  , null+  )+where++import Prelude hiding (elem, lookup, null)++import Data.BCP47+import Data.BCP47.Trie.Internal+import qualified Data.Map as Map+import Data.Maybe (isJust)++-- | Lookup the most relevant item for a tag+lookup :: BCP47 -> Trie a -> Maybe a+lookup tag trie = lookup2 tag =<< Map.lookup (language tag) (unLanguage trie)++-- | Lookup an exact match for a tag+match :: BCP47 -> Trie a -> Maybe a+match tag trie = match2 tag =<< Map.lookup (language tag) (unLanguage trie)++-- | Check if a tag exists in the 'Trie'+elem :: BCP47 -> Trie a -> Bool+elem tag = isJust . match tag++-- | Check if a 'Trie' is empty+null :: Trie a -> Bool+null = Map.null . unLanguage
+ library/Data/BCP47/Trie/Internal.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}++module Data.BCP47.Trie.Internal+  ( Trie(..)+  , fromList+  , singleton+  , union+  , unionWith+  , unionUsing+  , Trie2(..)+  , Subtags(..)+  , singleton2+  , lookup2+  , match2+  , union2+  , union2Using+  , fromSubtags+  )+  where++import Control.Applicative (liftA2, (<|>))+import Data.BCP47+import Data.BCP47.Internal.Subtags+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Monoid (Last(Last, getLast))+import Test.QuickCheck.Arbitrary++-- | A trie mapping 'BCP47' tags to values+newtype Trie a+  = Trie { unLanguage :: Map ISO639_1 (Trie2 a)}+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)++instance Semigroup a => Semigroup (Trie a) where+  x <> y = unionUsing (liftA2 (<>)) x y++instance Semigroup a => Monoid (Trie a) where+  mempty = Trie mempty++instance Arbitrary a => Arbitrary (Trie a) where+  arbitrary = fromList <$> arbitrary++-- | Construct a 'Trie' from a list of tag/value pairs.+fromList :: [(BCP47, a)] -> Trie a+fromList = foldr (union . uncurry singleton) (Trie mempty)++-- | Construct a 'Trie' from a single tag/value pair.+singleton :: BCP47 -> a -> Trie a+singleton tag = Trie . Map.singleton (language tag) . singleton2 tag++-- | A left-biased union of two 'Trie' structures. The left value is prefered+-- when duplicate tags are found.+union :: Trie a -> Trie a -> Trie a+union = unionUsing (<|>)++-- | 'union' with a combining function.+unionWith :: (a -> a -> a) -> Trie a -> Trie a -> Trie a+unionWith f = unionUsing (liftA2 f)++unionUsing :: (Maybe a -> Maybe a -> Maybe a) -> Trie a -> Trie a -> Trie a+unionUsing f (Trie x) (Trie y) = Trie $ Map.unionWith (union2Using f) x y++data Trie2 a = Trie2 (Maybe a) (Map Subtags (Trie2 a))+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)++instance Semigroup a => Semigroup (Trie2 a) where+  x <> y = union2Using (liftA2 (<>)) x y++instance Monoid a => Monoid (Trie2 a) where+  mempty = Trie2 mempty mempty++singleton2 :: BCP47 -> a -> Trie2 a+singleton2 tag = fromSubtags (toSubtags tag)++fromSubtags :: [Subtags] -> a -> Trie2 a+fromSubtags =+  foldr (\path leaf -> Trie2 Nothing . Map.singleton path . leaf) toVal++toVal :: a -> Trie2 a+toVal x = Trie2 (Just x) mempty++lookup2 :: BCP47 -> Trie2 a -> Maybe a+lookup2 tag = getLast . go (toSubtags tag)+ where+  go :: [Subtags] -> Trie2 a -> Last a+  go [] (Trie2 mVal _) = Last mVal+  go (p : ps) (Trie2 mVal children) =+    Last mVal <> (go ps =<< (Last $ Map.lookup p children))++match2 :: BCP47 -> Trie2 a -> Maybe a+match2 tag = go (toSubtags tag)+ where+  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) =+  Trie2 (f x y) (Map.unionWith union2 xs ys)
+ tests/Data/BCP47/TrieSpec.hs view
@@ -0,0 +1,85 @@+module Data.BCP47.TrieSpec+  ( spec+  ) where++import Prelude hiding (lookup)++import Data.BCP47+import Data.BCP47.Trie+import Test.Hspec+import Test.QuickCheck++spec :: Spec+spec = do+  describe "Trie" $ do+    it "has equality" $ property $ \xs ->+      fromList xs `shouldBe` (fromList xs :: Trie Bool)++    it "can be ordered"+      $ singleton en "color"+      < singleton es "color"+      `shouldBe` True++  describe "lookup" $ do+    it "should always lookup a path it inserts" $ property $ \tag ->+      lookup tag (singleton tag "string") `shouldBe` Just "string"++    it "lookups no match" $ do+      let trie = fromList [(en, "color"), (enGB, "colour")]+      lookup es trie `shouldBe` Nothing++    it "lookups no match deeply" $ do+      let trie = fromList [(enGBTJP, "colour")]+      lookup enGB trie `shouldBe` Nothing++    it "lookups an exact match" $ do+      let trie = fromList [(en, "color"), (enGB, "colour")]+      lookup en trie `shouldBe` Just "color"++    it "lookups on just language" $ do+      let trie = fromList [(en, "color"), (es, "colour")]+      lookup es trie `shouldBe` Just "colour"++    it "lookups a deep exact match" $ do+      let trie = fromList [(enGBTJP, "foo"), (enGB, "colour")]+      lookup enGBTJP trie `shouldBe` Just "foo"++    it "lookups a relevant match" $ do+      let trie = fromList [(en, "color"), (enGB, "colour")]+      lookup enTJP trie `shouldBe` Just "color"++    it "lookups a deep relevant match" $ do+      let trie = fromList [(en, "color"), (enGB, "colour")]+      lookup enGBTJP trie `shouldBe` Just "colour"++  describe "match" $ do+    it "should always match a path it inserts" $ property $ \tag ->+      match tag (singleton tag "string") `shouldBe` Just "string"++    it "matches no match" $ do+      let trie = fromList [(en, "color"), (enGB, "colour")]+      match es trie `shouldBe` Nothing++    it "matches no match deeply" $ do+      let trie = fromList [(enGBTJP, "colour")]+      match enGB trie `shouldBe` Nothing++    it "matches an exact match" $ do+      let trie = fromList [(en, "color"), (enGB, "colour")]+      match en trie `shouldBe` Just "color"++    it "matches on just language" $ do+      let trie = fromList [(en, "color"), (es, "colour")]+      match es trie `shouldBe` Just "colour"++    it "matches a deep exact match" $ do+      let trie = fromList [(enGBTJP, "foo"), (enGB, "colour")]+      match enGBTJP trie `shouldBe` Just "foo"++    it "matches a relevant match" $ do+      let trie = fromList [(en, "color"), (enGB, "colour")]+      match enTJP trie `shouldBe` Nothing++    it "matches a deep relevant match" $ do+      let trie = fromList [(en, "color"), (enGB, "colour")]+      match enGBTJP trie `shouldBe` Nothing
+ tests/Data/BCP47Spec.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Data.BCP47Spec+  ( spec+  ) where++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 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"+      language lng `shouldBe` ZH+      extendedLanguageSubtags lng+        `shouldBe` Set.singleton (LanguageExtension "abc-def-zxy")+      script lng `shouldBe` Just (Script "Hant")+      region lng `shouldBe` Just china+      variants lng `shouldBe` Set.singleton (Variant "1967")+      extensions lng `shouldBe` Set.singleton (Extension "y-extensi")+      privateUse lng+        `shouldBe` Set.fromList [PrivateUse "private1", PrivateUse "private2"]++    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"+      language lng `shouldBe` ZH+      extendedLanguageSubtags lng `shouldBe` Set.empty+      script lng `shouldBe` Nothing+      region lng `shouldBe` Nothing+      variants lng `shouldBe` Set.singleton (Variant "CNUVWXYX")+      privateUse lng `shouldBe` Set.empty++  describe "Arbitrary"+    . it "can parse arbitrary generated tags"+    . property+    $ \tag -> fromText (toText tag) `shouldBe` Right tag++  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
+ tests/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}