bcp47 0.1.0.0 → 0.2.0.0
raw patch · 13 files changed
+191/−92 lines, 13 filesdep ~aesondep ~containersdep ~countrynew-uploader
Dependency ranges changed: aeson, containers, country, doctest, hspec, megaparsec, text
Files
- ChangeLog.md +11/−2
- bcp47.cabal +37/−36
- library/Data/BCP47.hs +15/−4
- library/Data/BCP47/Internal/Extension.hs +3/−2
- library/Data/BCP47/Internal/LanguageExtension.hs +2/−1
- library/Data/BCP47/Internal/Parser.hs +6/−2
- library/Data/BCP47/Internal/PrivateUse.hs +3/−2
- library/Data/BCP47/Internal/Script.hs +2/−1
- library/Data/BCP47/Internal/Subtags.hs +2/−1
- library/Data/BCP47/Internal/Variant.hs +11/−10
- library/Data/BCP47/Trie.hs +10/−5
- library/Data/BCP47/Trie/Internal.hs +32/−11
- tests/Data/BCP47/TrieSpec.hs +57/−15
ChangeLog.md view
@@ -1,3 +1,12 @@-# Changelog for bcp47+## [*Unreleased*](https://github.com/freckle/bcp47/compare/bcp47-v0.2.0.0...master) -## Unreleased changes+None++## [v0.2.1.0](https://github.com/freckle/bcp47/compare/bcp47-v0.1.0.0...bcp47-v0.2.0.0)++- Add `mapMaybe` for `Trie` [#16](https://github.com/freckle/bcp47/pull/16)+- Make `Trie` a non-empty data type [#11](https://github.com/freckle/bcp47/pull/11)++## [v0.1.0.0](https://github.com/freckle/bcp47/tree/v0.1.0.0)++First tagged release.
bcp47.cabal view
@@ -1,14 +1,14 @@-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+cabal-version: 1.12+name: bcp47+version: 0.2.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./@@ -29,14 +29,15 @@ > print $ match en color -- Just "color" > print $ match enGB color -- Nothing > print $ lookup enGB color -- Just "color"-category: Data, Data Structures-build-type: Simple++category: Data, Data Structures+build-type: Simple extra-source-files: README.md ChangeLog.md source-repository head- type: git+ type: git location: https://github.com/freckle/bcp47 library@@ -54,48 +55,48 @@ Data.BCP47.Internal.Variant Data.BCP47.Trie Data.BCP47.Trie.Internal- hs-source-dirs: library- other-modules:- Paths_bcp47++ 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,+ aeson >=1.4.7.1 && <1.5, base >=4.7 && <5,- containers >=0.6.0.1 && <0.7,- country >=0.1.6 && <0.2,+ containers >=0.6.2.1 && <0.7,+ country >=0.2.1 && <0.3, 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+ megaparsec >=8.0.0 && <8.1,+ text >=1.2.4.0 && <1.3 test-suite doctest- type: exitcode-stdio-1.0- main-is: Main.hs- hs-source-dirs: doctest- other-modules:- Paths_bcp47+ 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+ doctest >=0.16.3 && <0.17 test-suite spec- type: exitcode-stdio-1.0- main-is: Main.hs- hs-source-dirs: tests+ 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,+ aeson >=1.4.7.1 && <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,+ containers >=0.6.2.1 && <0.7,+ country >=0.2.1 && <0.3,+ hspec >=2.7.4 && <2.8, iso639 >=0.1.0.3 && <0.2,- text >=1.2.3.1 && <1.3+ text >=1.2.4.0 && <1.3
library/Data/BCP47.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -25,6 +26,7 @@ , mkLanguage , mkLocalized , fromText+ , parser -- * Serialization , toText -- * Subtags@@ -82,7 +84,6 @@ import Control.Applicative ((<|>)) import Control.Monad (MonadPlus)-import Country (Country) import Country.Identifier (unitedKingdomOfGreatBritainAndNorthernIreland, unitedStatesOfAmerica) import Data.Aeson@@ -122,7 +123,7 @@ { language :: ISO639_1 -- ^ The language subtag , subtags :: Set Subtags }- deriving (Eq, Ord)+ deriving stock (Eq, Ord) instance Arbitrary BCP47 where arbitrary = BCP47 <$> elements [EN, ES] <*> specs@@ -285,10 +286,20 @@ -- Right zh -- fromText :: Text -> Either Text BCP47-fromText = first (pack . errorBundlePretty) . parse parser "fromText"+fromText =+ first (pack . errorBundlePretty) . parse (parser <* hidden eof) "fromText" +-- |+--+-- >>> _example $ pack "en;"+-- Right (en,';')+--+_example :: Text -> Either Text (BCP47, Char)+_example = first (pack . errorBundlePretty) . parse p "example"+ where p = (,) <$> parser <*> char ';'+ parser :: Parsec Void Text BCP47-parser = BCP47 <$> languageP <*> subtagsP <* hidden eof+parser = BCP47 <$> languageP <*> subtagsP where subtagsP = mconcat <$> sequenceA [ manyAsSet SpecifyLanguageExtension (try (char '-' *> languageExtensionP))
library/Data/BCP47/Internal/Extension.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} module Data.BCP47.Internal.Extension@@ -27,12 +28,12 @@ -- that is not part of language identification. -- newtype Extension = Extension { extensionToText :: Text }- deriving (Show, Eq, Ord)+ deriving stock (Show, Eq, Ord) instance Arbitrary Extension where arbitrary = do prefix <- alphaChar `suchThat` (`notElem` ['x', 'X'])- len <- choose (2,8)+ len <- choose (2, 8) chars <- alphaNumString len pure . Extension . pack $ prefix : '-' : chars
library/Data/BCP47/Internal/LanguageExtension.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} module Data.BCP47.Internal.LanguageExtension@@ -26,7 +27,7 @@ -- tagged using an existing primary language subtag. -- newtype LanguageExtension = LanguageExtension { languageExtensionToText :: Text }- deriving (Show, Eq, Ord)+ deriving stock (Show, Eq, Ord) instance Arbitrary LanguageExtension where arbitrary = do
library/Data/BCP47/Internal/Parser.hs view
@@ -6,7 +6,7 @@ import Control.Monad (void) import Data.Text (Text) import Data.Void (Void)-import Text.Megaparsec (Parsec, eof, lookAhead)+import Text.Megaparsec (Parsec, eof, lookAhead, noneOf) import Text.Megaparsec.Char (char) -- | Ensure a subtag extends to the next '-' or end of input@@ -19,4 +19,8 @@ -- the legal characters in the next valid subtag. -- complete :: Parsec Void Text a -> Parsec Void Text a-complete parser = parser <* lookAhead (void (char '-') <|> eof)+complete parser =+ parser <* lookAhead (void (char '-') <|> eof <|> void (noneOf tagChars))++tagChars :: String+tagChars = '-' : ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9']
library/Data/BCP47/Internal/PrivateUse.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} module Data.BCP47.Internal.PrivateUse@@ -27,11 +28,11 @@ -- that are important in a given context by private agreement. -- newtype PrivateUse = PrivateUse { privateUseToText :: Text }- deriving (Show, Eq, Ord)+ deriving stock (Show, Eq, Ord) instance Arbitrary PrivateUse where arbitrary = do- len <- choose (1,8)+ len <- choose (1, 8) chars <- alphaNumString len pure . PrivateUse $ pack chars
library/Data/BCP47/Internal/Script.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} module Data.BCP47.Internal.Script@@ -24,7 +25,7 @@ -- dialects. -- newtype Script = Script { scriptToText :: Text }- deriving (Show, Eq, Ord)+ deriving stock (Show, Eq, Ord) instance Arbitrary Script where arbitrary = Script . pack <$> alphaString 4
library/Data/BCP47/Internal/Subtags.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} module Data.BCP47.Internal.Subtags ( Subtags(..)@@ -22,7 +23,7 @@ | SpecifyVariant Variant | SpecifyExtension Extension | SpecifyPrivateUse PrivateUse- deriving (Show, Eq, Ord, Generic)+ deriving stock (Show, Eq, Ord, Generic) instance Arbitrary Subtags where arbitrary = oneof
library/Data/BCP47/Internal/Variant.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} module Data.BCP47.Internal.Variant@@ -45,19 +46,19 @@ -- covered by other available subtags. -- newtype Variant = Variant { variantToText :: Text }- deriving (Show, Eq, Ord)+ deriving stock (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+ 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
library/Data/BCP47/Trie.hs view
@@ -6,13 +6,14 @@ module Data.BCP47.Trie ( Trie , fromList+ , fromNonEmpty , singleton , lookup , match , elem , union , unionWith- , null+ , mapMaybe ) where @@ -24,6 +25,14 @@ import Data.Maybe (isJust) -- | Lookup the most relevant item for a tag+--+-- "Lookup is used to select the single language tag that best matches the+-- language priority list for a given request...For example, if the language+-- range is 'de-ch', a lookup operation can produce content with the tags 'de'+-- 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) @@ -34,7 +43,3 @@ -- | 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
@@ -1,14 +1,15 @@-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-} module Data.BCP47.Trie.Internal ( Trie(..) , fromList+ , fromNonEmpty , singleton , union , unionWith , unionUsing+ , mapMaybe , Trie2(..) , Subtags(..) , singleton2@@ -17,35 +18,40 @@ , union2 , union2Using , fromSubtags+ , mapMaybe2 ) where import Control.Applicative (liftA2, (<|>)) 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 Test.QuickCheck.Arbitrary+import Test.QuickCheck.Modifiers (NonEmptyList(getNonEmpty)) -- | A trie mapping 'BCP47' tags to values newtype Trie a = Trie { unLanguage :: Map ISO639_1 (Trie2 a)}- deriving (Show, Eq, Ord, Functor, Foldable, Traversable)+ deriving stock (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+ arbitrary = fromNonEmpty . NE.fromList . getNonEmpty <$> arbitrary -- | Construct a 'Trie' from a list of tag/value pairs.-fromList :: [(BCP47, a)] -> Trie a-fromList = foldr (union . uncurry singleton) (Trie mempty)+fromList :: [(BCP47, a)] -> Maybe (Trie a)+fromList = fmap fromNonEmpty . NE.nonEmpty +-- | Construct a 'Trie' from a non empty list of tag/value pairs.+fromNonEmpty :: NonEmpty (BCP47, a) -> Trie a+fromNonEmpty = 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@@ -62,8 +68,15 @@ 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 +nullToMaybe :: Map k a -> Maybe (Map k a)+nullToMaybe m = if Map.null m then Nothing else Just m++-- Like `Map.mapMaybe` but returns a `Maybe` because `Trie` should be non-empty+mapMaybe :: (a -> Maybe b) -> Trie a -> Maybe (Trie b)+mapMaybe f (Trie x) = Trie <$> nullToMaybe (Map.mapMaybe (mapMaybe2 f) x)+ data Trie2 a = Trie2 (Maybe a) (Map Subtags (Trie2 a))- deriving (Show, Eq, Ord, Functor, Foldable, Traversable)+ deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) instance Semigroup a => Semigroup (Trie2 a) where x <> y = union2Using (liftA2 (<>)) x y@@ -71,6 +84,14 @@ instance Monoid a => Monoid (Trie2 a) where mempty = Trie2 mempty mempty +mapMaybe2 :: (a -> Maybe b) -> Trie2 a -> Maybe (Trie2 b)+mapMaybe2 f = go+ where+ go (Trie2 x xs) = case (f =<< x, nullToMaybe $ Map.mapMaybe go xs) of+ (Nothing, Nothing) -> Nothing+ (Just x', Nothing) -> Just $ Trie2 (Just x') mempty+ (x', Just xs') -> Just $ Trie2 x' xs'+ singleton2 :: BCP47 -> a -> Trie2 a singleton2 tag = fromSubtags (toSubtags tag) @@ -87,7 +108,7 @@ 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))+ Last mVal <> (go ps =<< Last (Map.lookup p children)) match2 :: BCP47 -> Trie2 a -> Maybe a match2 tag = go (toSubtags tag)
tests/Data/BCP47/TrieSpec.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE TypeApplications #-}+ module Data.BCP47.TrieSpec ( spec ) where@@ -6,50 +8,90 @@ 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 +catMaybes :: Trie (Maybe a) -> Maybe (Trie a)+catMaybes = mapMaybe id+ spec :: Spec spec = do describe "Trie" $ do it "has equality" $ property $ \xs ->- fromList xs `shouldBe` (fromList xs :: Trie Bool)+ fromList xs `shouldBe` (fromList xs :: Maybe (Trie Bool)) it "can be ordered" $ singleton en "color" < singleton es "color" `shouldBe` True + describe "mapMaybe" $ do+ it "Justs are constant" $ property $ \xs ->+ let+ trie = fromList xs :: Maybe (Trie (Maybe Bool))+ expected = List.sort <$> do+ m <- Maybe.catMaybes . toList <$> trie+ if null m then Nothing else Just m+ actual = List.sort . toList <$> (catMaybes =<< trie)+ in expected == actual++ it "returns Nothing if empty resulting Trie" $ do+ let+ (Just given) = fromList [(en, Nothing), (enGB, Nothing)]+ expected = fromList @String []+ catMaybes given `shouldBe` expected++ it "returns top-level Just" $ do+ let+ (Just given) = fromList [(en, Just "color"), (enGB, Nothing)]+ expected = fromList [(en, "color")]+ catMaybes given `shouldBe` expected++ it "returns leaf Just" $ do+ let+ (Just given) = fromList [(en, Nothing), (enGB, Just "colour")]+ expected = fromList [(enGB, "colour")]+ catMaybes given `shouldBe` expected++ it "returns both leaf and top-level Justs" $ do+ let+ (Just given) = fromList [(en, Just "color"), (enGB, Just "colour")]+ expected = fromList [(en, "color"), (enGB, "colour")]+ catMaybes given `shouldBe` expected+ 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")]+ let Just trie = fromList [(en, "color"), (enGB, "colour")] lookup es trie `shouldBe` Nothing it "lookups no match deeply" $ do- let trie = fromList [(enGBTJP, "colour")]+ let Just trie = fromList [(enGBTJP, "colour")] lookup enGB trie `shouldBe` Nothing it "lookups an exact match" $ do- let trie = fromList [(en, "color"), (enGB, "colour")]+ let Just 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")]+ let Just 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")]+ let Just 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")]+ let Just 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")]+ let Just trie = fromList [(en, "color"), (enGB, "colour")] lookup enGBTJP trie `shouldBe` Just "colour" describe "match" $ do@@ -57,29 +99,29 @@ match tag (singleton tag "string") `shouldBe` Just "string" it "matches no match" $ do- let trie = fromList [(en, "color"), (enGB, "colour")]+ let Just trie = fromList [(en, "color"), (enGB, "colour")] match es trie `shouldBe` Nothing it "matches no match deeply" $ do- let trie = fromList [(enGBTJP, "colour")]+ let Just trie = fromList [(enGBTJP, "colour")] match enGB trie `shouldBe` Nothing it "matches an exact match" $ do- let trie = fromList [(en, "color"), (enGB, "colour")]+ let Just 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")]+ let Just 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")]+ let Just 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")]+ let Just 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")]+ let Just trie = fromList [(en, "color"), (enGB, "colour")] match enGBTJP trie `shouldBe` Nothing