diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -2,6 +2,18 @@
`unicode-collation` uses [PVP Versioning](https://pvp.haskell.org).
+## 0.1.1
+
+* Fix fallback behavior with `lookupLang` (#3). Previously `lookupLang`
+ would let `de` fall back to `de-u-co-phonebk`.
+
+* Add `collatorLang`, which reports the `Lang` used for
+ tailoring (which may be different from the `Lang` passed to
+ `collatorFor`, because of fallbacks).
+
+* Add `--verbose` option to executable. This prints the fallback
+ Lang used for tailoring to stderr to help diagnose issues.
+
## 0.1
* Initial release.
diff --git a/app/Main.hs b/app/Main.hs
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -22,8 +22,9 @@
when (any isHelp args) $ do
putStrLn "Usage: unicode-collate [COLLATION]"
putStrLn "Options:"
- putStrLn " --help Print usage information"
- putStrLn " --list List supported collations"
+ putStrLn " --help Print usage information"
+ putStrLn " --list List supported collations"
+ putStrLn " --verbose Diagnostic information to stderr"
putStrLn ""
putStrLn "Sorts lines from stdin using the specified collation."
putStrLn "COLLATION is a BCP47 language code. Examples:"
@@ -39,9 +40,14 @@
mapM_ (T.putStrLn . renderLang . fst) tailorings
exitSuccess
- spec <- maybe "root" T.pack . listToMaybe <$> getArgs
+ let isOpt ('-':_) = True
+ isOpt _ = False
+ spec <- maybe "root" T.pack . listToMaybe . filter (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
handleError :: String -> IO a
diff --git a/benchmark/Main.hs b/benchmark/Main.hs
--- a/benchmark/Main.hs
+++ b/benchmark/Main.hs
@@ -6,6 +6,7 @@
import Test.QuickCheck
import Data.Text (Text)
import qualified Data.Text.ICU as ICU
+import Data.Text.ICU.Collate (Attribute(..), Strength(..))
import Text.Collate
import Test.QuickCheck.Instances.Text ()
import Data.List (sortBy)
@@ -15,10 +16,18 @@
main = do
(randomTexts :: [Text]) <- generate (infiniteListOf arbitrary)
let tenThousand = take 10000 randomTexts
+ let icuCollator lang = ICU.collatorWith (ICU.Locale lang)
+ [NormalizationMode True, Strength Quaternary]
defaultMain
- [ bench "sort a list of 10000 random Texts"
- (whnf (sortBy (collate rootCollator)) tenThousand)
- , bench "sort same list with text-icu"
- (whnf (sortBy (ICU.collate (ICU.collator ICU.Root))) tenThousand)
+ [ bench "sort a list of 10000 random Texts (en)"
+ (whnf (sortBy (collate (collatorFor "en"))) tenThousand)
+ , bench "sort same list with text-icu (en)"
+ (whnf (sortBy (ICU.collate (icuCollator "en"))) tenThousand)
+ , bench "sort a list of 10000 random Texts (zh)"
+ (whnf (sortBy (collate (collatorFor "zh"))) tenThousand)
+ , bench "sort same list with text-icu (zh)"
+ (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)
]
diff --git a/src/Text/Collate.hs b/src/Text/Collate.hs
--- a/src/Text/Collate.hs
+++ b/src/Text/Collate.hs
@@ -44,7 +44,7 @@
>>> collate se "ö" "z"
GT
>>> sortKey de "ö"
-SortKey [0x213C,0x2007,0x0000,0x0021,0x0021,0x0000,0x0002,0x0002,0x0000,0xFFFF,0xFFFF]
+SortKey [0x213C,0x0000,0x0020,0x002B,0x0000,0x0002,0x0002,0x0000,0xFFFF,0xFFFF]
>>> sortKey se "ö"
SortKey [0x22FD,0x0000,0x0020,0x0000,0x0002,0x0000,0xFFFF]
@@ -134,6 +134,7 @@
, SortKey(..)
, sortKey
, VariableWeighting(..)
+ , collatorLang
, setVariableWeighting
, setNormalization
, setFrenchAccents
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
@@ -6,6 +6,7 @@
, SortKey(..)
, VariableWeighting(..)
, rootCollator
+ , collatorLang
, setVariableWeighting
, setFrenchAccents
, setUpperBeforeLower
@@ -38,7 +39,8 @@
data CollatorOptions =
CollatorOptions
- { optVariableWeighting :: VariableWeighting -- ^ Method for handling
+ { optLang :: Maybe Lang -- ^ Which lang was used for tailoring
+ , optVariableWeighting :: VariableWeighting -- ^ Method for handling
-- variable elements (see ,
-- Tables 11 and 12).
, optFrenchAccents :: Bool -- ^ If True, secondary weights are scanned
@@ -82,6 +84,14 @@
rootCollator =
mkCollator defaultCollatorOptions{ optCollation = ducetCollation }
+-- | Report 'Lang' used for tailoring in a collator.
+-- Note that because of fallbac 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.
+collatorLang :: Collator -> Maybe Lang
+collatorLang = optLang . collatorOptions
+
-- | Set method for handling variable elements (punctuation
-- and spaces): see ,
-- Tables 11 and 12.
@@ -133,7 +143,8 @@
defaultCollatorOptions :: CollatorOptions
defaultCollatorOptions =
CollatorOptions
- { optVariableWeighting = NonIgnorable
+ { optLang = Nothing
+ , optVariableWeighting = NonIgnorable
, optFrenchAccents = False
, optUpperBeforeLower = False
, optNormalize = True
@@ -160,6 +171,7 @@
collatorFor lang = mkCollator opts
where
opts = defaultCollatorOptions{
+ optLang = langUsed,
optFrenchAccents =
case lookup "u" exts >>= lookup "kb" of
Just "" -> True
@@ -191,7 +203,9 @@
Just "false" -> False
_ -> True,
optCollation = ducetCollation <> tailoring }
- tailoring = maybe mempty snd $ lookupLang lang tailorings
+ (langUsed, tailoring) = case lookupLang lang tailorings of
+ Nothing -> (Nothing, mempty)
+ Just (l,t) -> (Just l, t)
exts = langExtensions lang
-- | Returns a collator constructed using the collation and
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
@@ -10,7 +10,7 @@
, lookupLang
)
where
-import Data.Maybe (listToMaybe)
+import Data.Maybe (listToMaybe, mapMaybe)
import Control.Monad (mzero)
import Data.Ord (Down(..))
import Data.List (sortOn)
@@ -47,26 +47,32 @@
return $ Lang a b c d e f
-- | Find best match for a 'Lang' in an association list.
--- We require a match in 'langLanguage'; after that,
--- we look for matches in the following priority order:
--- 'langScript', 'langRegion', 'langVariants',
--- 'langExtensions' (under @"u"@),
--- collation ('langExtensions' under @"u-co"@).
lookupLang :: Lang -> [(Lang, a)] -> Maybe (Lang, a)
lookupLang lang =
- listToMaybe
- . sortOn (Down . scoreMatch)
- . filter (\(l,_) -> langLanguage l == langLanguage lang)
+ fmap snd
+ . listToMaybe
+ . sortOn (Down . fst)
+ . (mapMaybe (\(l,t) ->
+ case match l of
+ Nothing -> Nothing
+ Just x -> Just (x,(l,t))))
where
- scoreMatch :: (Lang, a) -> Int
- scoreMatch (l,_) =
- (if langScript l == langScript lang then 20 else 0) +
- (if langRegion l == langRegion lang then 10 else 0) +
- (if langVariants l == langVariants lang then 5 else 0) +
- (if lookup "u" (langExtensions l) ==
- lookup "u" (langExtensions lang) then 2 else 0) +
- (if (lookup "u" (langExtensions l) >>= lookup "co") ==
- (lookup "u" (langExtensions lang) >>= lookup "co") then 1 else 0)
+ langsMatch l = if langLanguage lang == langLanguage l
+ then Just True
+ else Nothing
+ maybeMatch f l = case (f l, f lang) of
+ (Nothing, Nothing) -> Just True
+ (Nothing, Just _) -> Just False
+ (Just x, mby) -> case mby of
+ Just y | x == y -> Just True
+ _ -> Nothing
+ langCollation l = lookup "u" (langExtensions l) >>= lookup "co"
+ match l = do
+ lm <- langsMatch l
+ sm <- maybeMatch langScript l
+ rm <- maybeMatch langRegion l
+ cm <- maybeMatch langCollation l
+ return (lm,sm,rm,cm)
-- | Render a 'Lang' in BCP 47 form.
renderLang :: Lang -> Text
diff --git a/stack.yaml b/stack.yaml
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,7 @@
resolver: lts-17.5
+flags:
+ unicode-collation:
+ executable: true
extra-deps:
- git: https://github.com/WorldSEnder/text-icu
commit: 7657227a7ca8ad13be86db5c190b806774a5fd6b
diff --git a/test/unit.hs b/test/unit.hs
--- a/test/unit.hs
+++ b/test/unit.hs
@@ -97,6 +97,20 @@
(map langParseTest langPairs)
, testGroup "BCP 47 Lang round-trip"
(map langRoundTripTest langPairs)
+ , testGroup "collatorLang and fallback behavior"
+ [ testCase "de => ROOT" $
+ collatorLang "de" @?= Nothing
+ , testCase "de-AT => ROOT" $
+ collatorLang "dt-AT" @?= Nothing
+ , testCase "es-u-co-trad" $
+ collatorLang "es-ES" @?= Just (Lang "es" Nothing Nothing [] [] [])
+ , testCase "de-DE-u-co-phonebk" $
+ collatorLang "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" @?=
+ Just (Lang "es" Nothing Nothing [] [] [])
+ ]
]
emptyLang :: Lang
diff --git a/unicode-collation.cabal b/unicode-collation.cabal
--- a/unicode-collation.cabal
+++ b/unicode-collation.cabal
@@ -1,7 +1,7 @@
cabal-version: 2.2
name: unicode-collation
-version: 0.1
-synopsis: Haskell implementation of the Unicode Collation Algorithm.
+version: 0.1.1
+synopsis: Haskell implementation of the Unicode Collation Algorithm
description: This library provides a pure Haskell implementation of
the Unicode Collation Algorithm described at
. It is not