diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/benchmark/Main.hs b/benchmark/Main.hs --- a/benchmark/Main.hs +++ b/benchmark/Main.hs @@ -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) ] diff --git a/src/Text/Collate.hs b/src/Text/Collate.hs --- a/src/Text/Collate.hs +++ b/src/Text/Collate.hs @@ -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 - - diff --git a/src/Text/Collate/Collation.hs b/src/Text/Collate/Collation.hs --- a/src/Text/Collate/Collation.hs +++ b/src/Text/Collate/Collation.hs @@ -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 . -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)) diff --git a/src/Text/Collate/Collator.hs b/src/Text/Collate/Collator.hs --- a/src/Text/Collate/Collator.hs +++ b/src/Text/Collate/Collator.hs @@ -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 . +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 , -- 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 , -- 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 diff --git a/src/Text/Collate/Lang.hs b/src/Text/Collate/Lang.hs --- a/src/Text/Collate/Lang.hs +++ b/src/Text/Collate/Lang.hs @@ -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 diff --git a/test/unit.hs b/test/unit.hs --- a/test/unit.hs +++ b/test/unit.hs @@ -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" - diff --git a/unicode-collation.cabal b/unicode-collation.cabal --- a/unicode-collation.cabal +++ b/unicode-collation.cabal @@ -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