unicode-collation 0.1.1 → 0.1.2
raw patch · 9 files changed
+211/−96 lines, 9 filesdep ~unicode-transforms
Dependency ranges changed: unicode-transforms
Files
- CHANGELOG.md +33/−4
- app/Main.hs +51/−10
- benchmark/Main.hs +8/−0
- src/Text/Collate.hs +20/−5
- src/Text/Collate/Collation.hs +8/−23
- src/Text/Collate/Collator.hs +78/−36
- src/Text/Collate/Lang.hs +2/−2
- test/unit.hs +9/−15
- unicode-collation.cabal +2/−1
CHANGELOG.md view
@@ -2,14 +2,43 @@ `unicode-collation` uses [PVP Versioning](https://pvp.haskell.org). -## 0.1.1+## 0.1.2 -* Fix fallback behavior with `lookupLang` (#3). Previously `lookupLang`- would let `de` fall back to `de-u-co-phonebk`.+* API change: Expose `collatorOptions` and `CollatorOptions`.+ Deprecate `collatorLang` which is now redundant. -* Add `collatorLang`, which reports the `Lang` used for+* API change: Export `renderSortKey`. This renders the sort key in a compact+ form, used by the CLDR collation tests. A vertical bar is used in place+ of 0000.++* Remove `optCollation` from `CollatorOptions`. Make the `Collation`+ a separate parameter of `Collator` instead. This doesn't affect+ the public API but it makes more sense conceptually.++* Avoid spurious FFFFs in sort keys. We were including FFFFs at L4+ of sort keys even with NonIgnorable, which is not right, though+ it should not affect the sort.++* Move `VariableWeighting` from `Collation` to `Collator` module.++* Add a benchmark for texts of length 1.++* Small optimization: don't generate sort key when strings are equal.++* Executable: add `--hex` and `--verbose` options. For testing purposes+ it is convenient to enter code points manually as hex numbers.+ `--verbose` causes diagnostic output to be printed to stderr,+ including the tailoring used, options, and normalized code points+ and sort keys.++## 0.1.1++* API change: Add `collatorLang`, which reports the `Lang` used for tailoring (which may be different from the `Lang` passed to `collatorFor`, because of fallbacks).++* Fix fallback behavior with `lookupLang` (#3). Previously `lookupLang`+ would let `de` fall back to `de-u-co-phonebk`. * Add `--verbose` option to executable. This prints the fallback Lang used for tailoring to stderr to help diagnose issues.
app/Main.hs view
@@ -2,14 +2,18 @@ module Main (main) where import Text.Collate+import Data.Char (chr, ord)+import Data.Text (Text) import qualified Data.Text.IO as T import qualified Data.Text as T-import Data.List (sortBy)+import qualified Data.Text.Read as TR+import Data.List (sortBy, find) import System.Environment (getArgs)-import Data.Maybe import Control.Monad import System.Exit+import Text.Printf import System.IO+import Data.Text.Normalize (normalize, NormalizationMode(NFD)) main :: IO () main = do@@ -22,9 +26,10 @@ when (any isHelp args) $ do putStrLn "Usage: unicode-collate [COLLATION]" putStrLn "Options:"- putStrLn " --help Print usage information"- putStrLn " --list List supported collations"- putStrLn " --verbose Diagnostic information to stderr"+ putStrLn " --hex Parse input as hex code points"+ putStrLn " --help Print usage information"+ putStrLn " --list List supported collations"+ putStrLn " --verbose Include diagnostic information" putStrLn "" putStrLn "Sorts lines from stdin using the specified collation." putStrLn "COLLATION is a BCP47 language code. Examples:"@@ -42,13 +47,49 @@ let isOpt ('-':_) = True isOpt _ = False- spec <- maybe "root" T.pack . listToMaybe . filter (not . isOpt) <$> getArgs+ spec <- maybe "root" T.pack . find (not . isOpt) <$> getArgs lang <- either handleError return $ parseLang spec let myCollator = collatorFor lang- when ("--verbose" `elem` args) $- hPutStrLn stderr $ "Tailoring: " <>- maybe "ROOT" (T.unpack . renderLang) (collatorLang myCollator)- T.getContents >>= mapM_ T.putStrLn . sortBy (collate myCollator) . T.lines+ let verbose = "--verbose" `elem` args+ let codepoints = "--hex" `elem` args+ let opts = collatorOptions myCollator+ when verbose $ do+ hPutStrLn stderr "Options:"+ hPutStrLn stderr $ " Tailoring: " <>+ maybe "ROOT" (T.unpack . renderLang) (optLang opts)+ hPutStrLn stderr $ " Variable weighting: " <>+ show (optVariableWeighting opts)+ hPutStrLn stderr $ " French accents: " <>+ show (optFrenchAccents opts)+ hPutStrLn stderr $ " Upper before lower: " <>+ show (optUpperBeforeLower opts)+ hPutStrLn stderr $ " Normalize: " <>+ show (optNormalize opts)+ let renderLine t = do+ t' <- if codepoints+ then parseAsCodePoints t+ else return t+ when verbose $+ hPutStrLn stderr $ renderCodePoints (normalize NFD t') ++ "; # ("+ ++ T.unpack t' ++ ") " ++ renderSortKey (sortKey myCollator t')+ T.putStrLn t'+ T.getContents >>= mapM_ renderLine . sortBy (collate myCollator) . T.lines++renderCodePoints :: Text -> String+renderCodePoints t =+ unwords $ map (printf "%04X" . ord) (T.unpack t)++parseAsCodePoints :: Text -> IO Text+parseAsCodePoints t = do+ let ws = T.words $ T.takeWhile (/=';') t -- everything after ; is ignored+ cs <- mapM parseCodePoint ws+ return $ T.pack $ map chr cs++parseCodePoint :: Text -> IO Int+parseCodePoint t =+ case TR.hexadecimal t of+ Right (x,t') | T.null t' -> return x+ _ -> handleError $ "Could not parse " <> show t <> " as hex code point." handleError :: String -> IO a handleError msg = do
benchmark/Main.hs view
@@ -5,6 +5,7 @@ import Test.Tasty.Bench import Test.QuickCheck import Data.Text (Text)+import qualified Data.Text as T import qualified Data.Text.ICU as ICU import Data.Text.ICU.Collate (Attribute(..), Strength(..)) import Text.Collate@@ -15,7 +16,10 @@ main :: IO () main = do (randomTexts :: [Text]) <- generate (infiniteListOf arbitrary)+ (randomSingletonTexts :: [Text]) <-+ generate (infiniteListOf (arbitrary `suchThat` (\t -> T.length t == 1))) let tenThousand = take 10000 randomTexts+ let tenThousandSingletons = take 10000 randomSingletonTexts let icuCollator lang = ICU.collatorWith (ICU.Locale lang) [NormalizationMode True, Strength Quaternary] defaultMain@@ -29,5 +33,9 @@ (whnf (sortBy (ICU.collate (icuCollator "zh"))) tenThousand) , bench "sort a list of 10000 random Texts (en-u-kk-false = no normalize)" (whnf (sortBy (collate (collatorFor "en-u-kk-false"))) tenThousand)+ , bench "sort a list of 10000 random Texts of length 1 (en)"+ (whnf (sortBy (collate (collatorFor "en"))) tenThousandSingletons)+ , bench "sort same list with text-icu (en)"+ (whnf (sortBy (ICU.collate (icuCollator "en"))) tenThousandSingletons) ]
src/Text/Collate.hs view
@@ -44,9 +44,9 @@ >>> collate se "ö" "z" GT >>> sortKey de "ö"-SortKey [0x213C,0x0000,0x0020,0x002B,0x0000,0x0002,0x0002,0x0000,0xFFFF,0xFFFF]+SortKey [0x213C,0x0000,0x0020,0x002B,0x0000,0x0002,0x0002] >>> sortKey se "ö"-SortKey [0x22FD,0x0000,0x0020,0x0000,0x0002,0x0000,0xFFFF]+SortKey [0x22FD,0x0000,0x0020,0x0000,0x0002] Because 'Collator' and 'Lang' have 'IsString' instances, you can just specify them using string literals, as in the above examples. Note, however,@@ -133,7 +133,10 @@ , rootCollator , SortKey(..) , sortKey+ , renderSortKey , VariableWeighting(..)+ , CollatorOptions(..)+ , collatorOptions , collatorLang , setVariableWeighting , setNormalization@@ -144,11 +147,23 @@ ) where import Text.Collate.Lang+ ( lookupLang, parseLang, Lang(..), renderLang ) import Text.Collate.Collator-import Text.Collate.Tailorings+ ( collatorFor,+ collator,+ setNormalization,+ setUpperBeforeLower,+ setFrenchAccents,+ setVariableWeighting,+ rootCollator,+ Collator(collate, sortKey, collatorOptions),+ SortKey(..),+ CollatorOptions(..),+ collatorLang,+ VariableWeighting(..),+ renderSortKey )+import Text.Collate.Tailorings ( tailorings ) -- $setup -- >>> :set -XQuasiQuotes -- >>> :set -XOverloadedStrings--
src/Text/Collate/Collation.hs view
@@ -7,7 +7,6 @@ {-# LANGUAGE DeriveLift #-} module Text.Collate.Collation ( Collation(..)- , VariableWeighting(..) , CollationElement(..) , unfoldCollation , insertElements@@ -44,16 +43,6 @@ #endif -- import Debug.Trace --- | 'VariableWeighting' affects how punctuation is treated.--- See <http://www.unicode.org/reports/tr10/#Variable_Weighting>.-data VariableWeighting =- NonIgnorable -- ^ Don't ignore punctuation (Deluge < deluge-)- | Blanked -- ^ Completely ignore punctuation (Deluge = deluge-)- | Shifted -- ^ Consider punctuation at lower priority- -- (de-luge < delu-ge < deluge < deluge- < Deluge)- | ShiftTrimmed -- ^ Variant of Shifted (deluge < de-luge < delu-ge)- deriving (Show, Eq, Ord)- data CollationElement = CollationElement { collationVariable :: !Bool@@ -182,14 +171,10 @@ getCollationElements :: Collation -> [Int] -> [CollationElement] getCollationElements collation = go where- matcher = matchLongestPrefix collation- go cs =- case matcher cs of- Nothing ->- case cs of- (c:rest) -> calculateImplicitWeight c ++ go rest- [] -> []- Just (elts, [], _) -> elts+ go [] = []+ go (c:cs) =+ case matchLongestPrefix collation (c:cs) of+ Nothing -> calculateImplicitWeight c ++ go cs Just (elts, is, subcollation) | null unblockedNonStarters -> elts ++ go is | otherwise ->@@ -202,10 +187,10 @@ where getUnblockedNonStarters _ [] = [] getUnblockedNonStarters n (x:xs)- = let ccc = canonicalCombiningClass x- in if ccc > n- then x : getUnblockedNonStarters ccc xs- else []+ = case canonicalCombiningClass x of+ ccc+ | ccc > n -> x : getUnblockedNonStarters ccc xs+ | otherwise -> [] unblockedNonStarters = getUnblockedNonStarters 0 is matches = mapMaybe (matchLongestPrefix subcollation) (take 24 (permutations unblockedNonStarters))
src/Text/Collate/Collator.hs view
@@ -4,9 +4,11 @@ module Text.Collate.Collator ( Collator(..) , SortKey(..)+ , renderSortKey , VariableWeighting(..) , rootCollator , collatorLang+ , CollatorOptions(..) , setVariableWeighting , setFrenchAccents , setUpperBeforeLower@@ -21,7 +23,7 @@ import Text.Collate.Lang import Text.Collate.Tailorings import Text.Collate.Collation (getCollationElements, Collation(..),- CollationElement(..), VariableWeighting(..))+ CollationElement(..)) import Data.Word (Word16) import Data.String import qualified Data.Text.Normalize as N@@ -37,9 +39,23 @@ import Data.Semigroup (Semigroup(..)) #endif +-- | 'VariableWeighting' affects how punctuation is treated.+-- See <http://www.unicode.org/reports/tr10/#Variable_Weighting>.+data VariableWeighting =+ NonIgnorable -- ^ Don't ignore punctuation (Deluge < deluge-)+ | Blanked -- ^ Completely ignore punctuation (Deluge = deluge-)+ | Shifted -- ^ Consider punctuation at lower priority+ -- (de-luge < delu-ge < deluge < deluge- < Deluge)+ | ShiftTrimmed -- ^ Variant of Shifted (deluge < de-luge < delu-ge)+ deriving (Show, Eq, Ord)+ data CollatorOptions = CollatorOptions- { optLang :: Maybe Lang -- ^ Which lang was used for tailoring+ { optLang :: Maybe Lang -- ^ 'Lang' used for tailoring.+ -- Note that because of fallback rules, this may be somewhat+ -- different from the 'Lang' passed to 'collatorFor'. This 'Lang'+ -- won't contain unicode extensions used to set options, but+ -- it will specify the collation if a non-default collation is being used. , optVariableWeighting :: VariableWeighting -- ^ Method for handling -- variable elements (see <http://www.unicode.org/reports/tr10/>, -- Tables 11 and 12).@@ -51,7 +67,6 @@ -- to NFD before collation elements are constructed. If the input -- is already normalized, this option can be set to False for -- better performance.- , optCollation :: Collation -- ^ The collation to use. } deriving (Show, Eq, Ord) showWordList :: [Word16] -> String@@ -65,6 +80,16 @@ instance Show SortKey where show (SortKey ws) = "SortKey " ++ showWordList ws +-- | Render sort key in the manner used in the CLDR collation test data:+-- the character '|' is used to separate the levels of the key and+-- corresponds to a 0 in the actual sort key.+renderSortKey :: SortKey -> String+renderSortKey (SortKey ws) = "[" ++ tohexes ws ++ "]"+ where+ tohexes = unwords . map tohex+ tohex 0 = "|"+ tohex x = printf "%04X" x+ -- Note that & b < q <<< Q is the same as & b < q, & q <<< Q -- Another syntactic shortcut is: -- & a <* bcd-gp-s => & a < b < c < d < e < f < g < p < q < r < s@@ -72,55 +97,67 @@ -- &[before 2] a << b => sorts sorts b before a -data Collator = Collator { collate :: Text -> Text -> Ordering- , sortKey :: Text -> SortKey- , collatorOptions :: CollatorOptions }+data Collator =+ Collator+ { -- | Compare two 'Text's+ collate :: Text -> Text -> Ordering+ -- | The sort key used to compare a 'Text'+ , sortKey :: Text -> SortKey+ -- | The options used for this 'Collator'+ , collatorOptions :: CollatorOptions+ -- | The collation table used for this 'Collator'+ , collatorCollation :: Collation+ } instance IsString Collator where fromString = collatorFor . fromString -- | Default collator based on DUCET table (@allkeys.txt@). rootCollator :: Collator-rootCollator =- mkCollator defaultCollatorOptions{ optCollation = ducetCollation }+rootCollator = mkCollator defaultCollatorOptions ducetCollation --- | Report 'Lang' used for tailoring in a collator.--- Note that because of fallbac rules, this may be somewhat+{-# DEPRECATED collatorLang "Use (optLang . collatorOptions)" #-}+-- | 'Lang' used for tailoring. Because of fallback rules, this may be somewhat -- different from the 'Lang' passed to 'collatorFor'. This 'Lang' -- won't contain unicode extensions used to set options, but--- it will contain the collation if a non-default collation is being used.+-- it will specify the collation if a non-default collation is being used. collatorLang :: Collator -> Maybe Lang collatorLang = optLang . collatorOptions +modifyCollatorOptions :: (CollatorOptions -> CollatorOptions)+ -> Collator -> Collator+modifyCollatorOptions f coll =+ mkCollator (f $ collatorOptions coll) (collatorCollation coll)+ -- | Set method for handling variable elements (punctuation -- and spaces): see <http://www.unicode.org/reports/tr10/>, -- Tables 11 and 12. setVariableWeighting :: VariableWeighting -> Collator -> Collator-setVariableWeighting w coll =- mkCollator (collatorOptions coll){ optVariableWeighting = w }+setVariableWeighting w =+ modifyCollatorOptions (\o -> o{ optVariableWeighting = w }) -- | The Unicode Collation Algorithm expects input to be normalized -- into its canonical decomposition (NFD). By default, collators perform -- this normalization. If your input is already normalized, you can increase -- performance by disabling this step: @setNormalization False@. setNormalization :: Bool -> Collator -> Collator-setNormalization normalize coll =- mkCollator (collatorOptions coll){ optNormalize = normalize }+setNormalization normalize =+ modifyCollatorOptions (\o -> o{ optNormalize = normalize }) -- | @setFrenchAccents True@ causes secondary weights to be scanned -- in reverse order, so we get the sorting -- @cote côte coté côté@ instead of @cote coté côte côté@. -- The default is usually @False@, except for @fr-CA@ where it is @True@. setFrenchAccents :: Bool -> Collator -> Collator-setFrenchAccents frAccents coll =- mkCollator (collatorOptions coll){ optFrenchAccents = frAccents }+setFrenchAccents frAccents =+ modifyCollatorOptions (\o -> o{ optFrenchAccents = frAccents }) -- | Most collations default to sorting lowercase letters before -- uppercase (exceptions: @mt@, @da@, @cu@). To select the opposite -- behavior, use @setUpperBeforeLower True@. setUpperBeforeLower :: Bool -> Collator -> Collator-setUpperBeforeLower upperBefore coll =- mkCollator (collatorOptions coll){ optUpperBeforeLower = upperBefore }+setUpperBeforeLower upperBefore =+ modifyCollatorOptions (\o -> o{ optUpperBeforeLower = upperBefore }) -- | Create a collator at compile time based on a BCP 47 language -- tag: e.g., @[collator|es-u-co-trad|]@. Requires the @QuasiQuotes@ extension.@@ -148,7 +185,6 @@ , optFrenchAccents = False , optUpperBeforeLower = False , optNormalize = True- , optCollation = ducetCollation } -- | Returns a collator based on a BCP 47 language tag.@@ -168,7 +204,7 @@ -- - The @kk@ keyword has the same effect as 'setNormalization' -- (e.g. @fr-u-kk-false@). collatorFor :: Lang -> Collator-collatorFor lang = mkCollator opts+collatorFor lang = mkCollator opts collation where opts = defaultCollatorOptions{ optLang = langUsed,@@ -201,29 +237,32 @@ Just "" -> True Just "true" -> True Just "false" -> False- _ -> True,- optCollation = ducetCollation <> tailoring }- (langUsed, tailoring) = case lookupLang lang tailorings of- Nothing -> (Nothing, mempty)- Just (l,t) -> (Just l, t)+ _ -> True }+ (langUsed, collation) =+ case lookupLang lang tailorings of+ Nothing -> (Nothing, ducetCollation)+ Just (l,tailoring) -> (Just l, ducetCollation <> tailoring) exts = langExtensions lang -- | Returns a collator constructed using the collation and -- variable weighting specified in the options.-mkCollator :: CollatorOptions -> Collator-mkCollator opts =- Collator { collate = comparing sortKey'+mkCollator :: CollatorOptions -> Collation -> Collator+mkCollator opts collation =+ Collator { collate = \x y -> if x == y -- optimization+ then EQ+ else comparing sortKey' x y , sortKey = sortKey' , collatorOptions = opts+ , collatorCollation = collation } where- sortKey' = toSortKey opts+ sortKey' = toSortKey opts collation -toSortKey :: CollatorOptions -> Text -> SortKey-toSortKey opts =+toSortKey :: CollatorOptions -> Collation -> Text -> SortKey+toSortKey opts collation = mkSortKey opts . handleVariable (optVariableWeighting opts)- . getCollationElements (optCollation opts)+ . getCollationElements collation . T.foldr ((:) . ord) [] . if optNormalize opts then N.normalize N.NFD@@ -279,9 +318,12 @@ l3s = filter (/=0) $ map ((if optUpperBeforeLower opts then switchUpperAndLower else id) . collationL3) elts- l4s = (case optVariableWeighting opts of- ShiftTrimmed -> trimTrailingFFFFs- _ -> id) $ filter (/=0) $ map collationL4 elts+ l4s = case optVariableWeighting opts of+ NonIgnorable -> []+ Blanked -> []+ ShiftTrimmed -> trimTrailingFFFFs l4s'+ Shifted -> l4s'+ l4s' = filter (/=0) $ map collationL4 elts switchUpperAndLower 0x0002 = 0x0008 switchUpperAndLower 0x0008 = 0x0002 switchUpperAndLower x = x
src/Text/Collate/Lang.hs view
@@ -52,10 +52,10 @@ fmap snd . listToMaybe . sortOn (Down . fst)- . (mapMaybe (\(l,t) ->+ . mapMaybe (\(l,t) -> case match l of Nothing -> Nothing- Just x -> Just (x,(l,t))))+ Just x -> Just (x,(l,t))) where langsMatch l = if langLanguage lang == langLanguage l then Just True
test/unit.hs view
@@ -97,18 +97,19 @@ (map langParseTest langPairs) , testGroup "BCP 47 Lang round-trip" (map langRoundTripTest langPairs)- , testGroup "collatorLang and fallback behavior"+ , testGroup "Lang fallback behavior" [ testCase "de => ROOT" $- collatorLang "de" @?= Nothing+ (optLang . collatorOptions) "de" @?= Nothing , testCase "de-AT => ROOT" $- collatorLang "dt-AT" @?= Nothing+ (optLang . collatorOptions) "dt-AT" @?= Nothing , testCase "es-u-co-trad" $- collatorLang "es-ES" @?= Just (Lang "es" Nothing Nothing [] [] [])+ (optLang . collatorOptions) "es-ES" @?=+ Just (Lang "es" Nothing Nothing [] [] []) , testCase "de-DE-u-co-phonebk" $- collatorLang "de-DE-u-co-phonebk" @?=+ (optLang . collatorOptions) "de-DE-u-co-phonebk" @?= Just (Lang "de" Nothing Nothing [] [("u",[("co","phonebk")])] []) , testCase "es-u-co-nonexist-kb" $- collatorLang "es-u-co-nonexist-kb" @?=+ (optLang . collatorOptions) "es-u-co-nonexist-kb" @?= Just (Lang "es" Nothing Nothing [] [] []) ] ]@@ -176,9 +177,9 @@ showHexes txt1 ++ " <= " ++ showHexes txt2 ++ "\n" ++ " Calculated sort keys:\n [" ++ showHexes txt1 ++ "] " ++- prettySortKey (sortKey coll txt1) ++ "\n [" +++ renderSortKey (sortKey coll txt1) ++ "\n [" ++ showHexes txt2 ++ "] " ++- prettySortKey (sortKey coll txt2)+ renderSortKey (sortKey coll txt2) variableOrderingCase :: (VariableWeighting , [Text]) -> TestTree variableOrderingCase (w , expected) =@@ -217,10 +218,3 @@ in if B8.take 1 bs == "#" then Nothing else Just (lineno, T.pack $ map chr codepoints)--prettySortKey :: SortKey -> String-prettySortKey (SortKey ws) = tohexes ws- where- tohexes = unwords . map tohex- tohex = printf "%04X"-
unicode-collation.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: unicode-collation-version: 0.1.1+version: 0.1.2 synopsis: Haskell implementation of the Unicode Collation Algorithm description: This library provides a pure Haskell implementation of the Unicode Collation Algorithm described at@@ -97,6 +97,7 @@ main-is: Main.hs build-depends: unicode-collation , containers+ , unicode-transforms , text ghc-options: -threaded -rtsopts