From 484b1482a58e27db9fc806dd1d95b2e880b06a03 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 24 Jun 2024 17:01:30 +1200 Subject: [PATCH] Test & fix langset comparisons. --- lib/Graphics/Text/Font/Choose.hs | 3 ++- lib/Graphics/Text/Font/Choose/LangSet.hs | 21 ++++++++-------- test/Main.hs | 32 ++++++++++++++++++++++++ 3 files changed, 45 insertions(+), 11 deletions(-) diff --git a/lib/Graphics/Text/Font/Choose.hs b/lib/Graphics/Text/Font/Choose.hs index 11862cd..00242d3 100644 --- a/lib/Graphics/Text/Font/Choose.hs +++ b/lib/Graphics/Text/Font/Choose.hs @@ -4,7 +4,8 @@ module Graphics.Text.Font.Choose( initLoadConfig, initLoadConfigAndFonts, initFonts, reinit, bringUptoDate, CharSet, ord, chr, parseCharSet, CharSet'(..), validCharSet', module Graphics.Text.Font.Choose.FontSet, - module Graphics.Text.Font.Choose.LangSet, + LangSet, LangSet'(..), LangComparison(..), validLangSet, validLangSet', + cmp, cmp', has, defaultLangs, langs, normalize, langCharSet, module Graphics.Text.Font.Choose.ObjectSet, Pattern, Pattern'(..), Binding(..), validPattern, validPattern', setValue, setValues, getValue, getValues, equalSubset, defaultSubstitute, diff --git a/lib/Graphics/Text/Font/Choose/LangSet.hs b/lib/Graphics/Text/Font/Choose/LangSet.hs index 17acec5..ce246da 100644 --- a/lib/Graphics/Text/Font/Choose/LangSet.hs +++ b/lib/Graphics/Text/Font/Choose/LangSet.hs @@ -2,10 +2,9 @@ -- | Languages supported by different fonts. module Graphics.Text.Font.Choose.LangSet( LangSet, LangSet'(..), module S, LangComparison(..), validLangSet, validLangSet', - cmp, has, defaultLangs, langs, normalize, langCharSet) where + cmp, cmp', has, defaultLangs, langs, normalize, langCharSet) where -import Data.Set (Set) -import qualified Data.Set as S +import Data.Set as S hiding (valid) import Data.Hashable (Hashable(..)) import Data.MessagePack (MessagePack(..)) @@ -32,7 +31,7 @@ instance Hashable LangSet' where -- | Can the given LangSet be processed by FontConfig? validLangSet :: LangSet -> Bool -validLangSet x = all validLang x && not (null x) +validLangSet x = all validLang x && not (Prelude.null x) -- | Can the given LangSet' be processed by FontConfig? validLangSet' :: LangSet' -> Bool validLangSet' = validLangSet . unLangSet @@ -47,21 +46,23 @@ instance Arbitrary LangSet' where arbitrary = LangSet' <$> S.fromList <$> listOf (elements $ S.toList $ unStrSet langs) -- | The result of `cmp`. -data LangComparison = SameLang -- ^ The locales share any language and territory pair - | SameTerritory -- ^ The locales share a language but differ in which territory that language is for - | DifferentLang -- ^ The locales share no languages in common +data LangComparison = DifferentLang -- ^ The locales share no languages in common + | SameLang -- ^ The locales share any language and territory pair + | DifferentTerritory -- ^ The locales share a language but differ in which territory that language is for deriving (Read, Show, Eq, Enum, Bounded) i2cmp :: Int -> LangComparison i2cmp 0 = DifferentLang i2cmp 1 = SameLang -i2cmp 2 = SameTerritory +i2cmp 2 = DifferentTerritory i2cmp _ = throw ErrOOM -- | Compares language coverage for the 2 given LangSets. -cmp :: LangSet' -> LangSet' -> LangComparison -cmp a b | valid a && valid b = i2cmp $ withMessage fcLangSetCompare [a, b] +cmp' :: LangSet' -> LangSet' -> LangComparison +cmp' a b | valid a && valid b = i2cmp $ withMessage fcLangSetCompare [a, b] | otherwise = DifferentLang where valid = validLangSet' +cmp :: LangSet -> LangSet -> LangComparison +cmp a b = LangSet' a `cmp'` LangSet' b foreign import capi "fontconfig-wrap.h" fcLangSetCompare :: CString -> Int -> Int diff --git a/test/Main.hs b/test/Main.hs index cf345b6..1c27e81 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -8,7 +8,9 @@ import Test.QuickCheck import Data.MessagePack as MP import qualified Data.Map as M +import qualified Data.Set as S import qualified Data.Text as Txt +import Data.Maybe (isJust) import Graphics.Text.Font.Choose import Graphics.Text.Font.Choose.Internal.Test @@ -64,3 +66,33 @@ main = hspec $ do roundtrip testPattern x `shouldBe` Just (x :: Pattern') prop "FontSet" $ \x -> let y = filter validPattern $ Prelude.map unPattern x in validFontSet y ==> roundtrip testFontSet y `shouldBe` Just y + describe "FontConfig Testsuite transliteration" $ do + it "All system fonts should have files" $ do + conf <- current + res <- fonts conf System + let files = getValue "file" `map` res :: [Maybe String] + all isJust files `shouldBe` True + it "Locale compare" $ do + S.singleton "ku-am" `cmp` S.singleton "ku-iq" `shouldBe` DifferentTerritory + S.singleton "ku-am" `cmp` S.singleton "ku-ir" `shouldBe` DifferentTerritory + S.singleton "ku-am" `cmp` S.singleton "ku-tr" `shouldBe` DifferentTerritory + S.singleton "ku-iq" `cmp` S.singleton "ku-ir" `shouldBe` DifferentTerritory + S.singleton "ku-iq" `cmp` S.singleton "ku-tr" `shouldBe` DifferentTerritory + S.singleton "ku-ir" `cmp` S.singleton "ku-tr" `shouldBe` DifferentTerritory + S.singleton "ps-af" `cmp` S.singleton "ps-pk" `shouldBe` DifferentTerritory + S.singleton "ti-er" `cmp` S.singleton "ti-et" `shouldBe` DifferentTerritory + S.singleton "zh-cn" `cmp` S.singleton "zh-hk" `shouldBe` DifferentTerritory + S.singleton "zh-cn" `cmp` S.singleton "zh-mo" `shouldBe` DifferentTerritory + S.singleton "zh-cn" `cmp` S.singleton "zh-sg" `shouldBe` DifferentTerritory + S.singleton "zh-cn" `cmp` S.singleton "zh-tw" `shouldBe` DifferentTerritory + S.singleton "zh-hk" `cmp` S.singleton "zh-mo" `shouldBe` DifferentTerritory + S.singleton "zh-hk" `cmp` S.singleton "zh-sg" `shouldBe` DifferentTerritory + S.singleton "zh-hk" `cmp` S.singleton "zh-tw" `shouldBe` DifferentTerritory + S.singleton "zh-mo" `cmp` S.singleton "zh-sg" `shouldBe` DifferentTerritory + S.singleton "zh-mo" `cmp` S.singleton "zh-tw" `shouldBe` DifferentTerritory + S.singleton "zh-sg" `cmp` S.singleton "zh-tw" `shouldBe` DifferentTerritory + S.singleton "mn-mn" `cmp` S.singleton "mn-cn" `shouldBe` DifferentTerritory + S.singleton "pap-an" `cmp` S.singleton "pap-aw" `shouldBe` DifferentTerritory + -- A couple additional ones so we know its not always responding with DifferentTerritory! + S.singleton "mn-mn" `cmp` S.singleton "mn-mn" `shouldBe` SameLang + S.singleton "mn-mn" `cmp` S.singleton "pap-an" `shouldBe` DifferentLang -- 2.30.2