unicode-data-scripts 0.2.0.1 → 0.3.0
raw patch · 11 files changed
+776/−259 lines, 11 filesdep +ghc-primdep +icudep −unicode-datadep ~basedep ~deepseqdep ~hspec
Dependencies added: ghc-prim, icu
Dependencies removed: unicode-data
Dependency ranges changed: base, deepseq, hspec, tasty
Files
- Changelog.md +7/−0
- bench/Main.hs +234/−36
- lib/Unicode/Char/General/Scripts.hs +64/−60
- lib/Unicode/Internal/Bits/Scripts.hs +138/−0
- lib/Unicode/Internal/Char/ScriptExtensions.hs too large to diff
- lib/Unicode/Internal/Char/Scripts.hs too large to diff
- lib/Unicode/Internal/Char/Scripts/Version.hs +20/−0
- test/ICU/ScriptsSpec.hs +108/−0
- test/Main.hs +10/−1
- test/Unicode/Char/General/ScriptsSpec.hs +150/−143
- unicode-data-scripts.cabal +45/−19
Changelog.md view
@@ -1,5 +1,12 @@ # Changelog +## 0.3.0 (July 2024)++- Add `unicodeVersion` and `scriptShortName` to `Unicode.Char.General.Scripts`.+- Fix the inlining of `Addr#` literals and reduce their size. This results in+ a sensible decrease of the executable size.+- Remove `unicode-data` dependency.+ ## 0.2.0.1 (December 2022) - Fix [Unicode scripts handling on big-endian architectures](https://github.com/composewell/unicode-data/issues/97).
bench/Main.hs view
@@ -1,51 +1,249 @@-import Control.DeepSeq (NFData, deepseq, force)-import Control.Exception (evaluate)-import Data.Ix (Ix(..))-import Test.Tasty.Bench- (Benchmark, bgroup, bench, defaultMain, env, nf)+{-# LANGUAGE CPP #-} -import qualified Unicode.Char.General as G+import Control.DeepSeq (NFData (..), deepseq)+import Control.Exception (assert, evaluate)+import Data.Char (ord)+import Data.Ix (Ix (..))+import Foreign (Storable (..))+import qualified GHC.Exts as Exts+import GHC.IO (IO (..))+import Test.Tasty.Bench (+ Benchmark,+ bench,+ bgroup,+ defaultMain,+ nf, env, bcompare,+ )++#if MIN_VERSION_base(4,10,0) && !MIN_VERSION_base(4,15,0)+import qualified GHC.Magic as Exts (noinline)+#endif++#ifdef HAS_ICU+import qualified ICU.Scripts as ICU+#endif+ import qualified Unicode.Char.General.Scripts as S main :: IO () main = defaultMain- [ bgroup "Unicode.Char.General.Script"- [ bgroup "script"- [ benchChars "unicode-data" (show . S.script)+ [ bgroupWithCharRange "Unicode.Char.General.Script" charRange $ \chars ->+ [ bgroupWithChars "script" chars+ [ Bench "unicode-data" (fromEnum . S.script)+#ifdef HAS_ICU+ , Bench "icu" (fromEnum . ICU.codepointScript . fromIntegral . ord)+#endif ] , bgroup "scriptDefinition"- [ benchNF "unicode-data" (show . S.scriptDefinition)+ [ benchNF "unicode-data" S.scriptDefinition ]- , bgroup "scriptExtensions"- [ benchChars "unicode-data" (show . S.scriptExtensions)+ , bgroupWithChars "scriptExtensions" chars+ [ Bench "unicode-data" (fmap fromEnum . S.scriptExtensions)+#ifdef HAS_ICU+ , Bench "icu" (fmap fromEnum . ICU.scriptExtensions)+#endif ] ] ] where- benchChars :: forall a. (NFData a) => String -> (Char -> a) -> Benchmark- benchChars t f =- -- Avoid side-effects with garbage collection (see tasty-bench doc)- env- (evaluate (force chars)) -- initialize- (bench t . nf (foldString f)) -- benchmark- where- -- Filter out: Surrogates, Private Use Areas and unsassigned code points- chars = filter isValid [minBound..maxBound]- isValid c = G.generalCategory c < G.Surrogate+ charRange = CharRange minBound maxBound - foldString :: forall a. (NFData a) => (Char -> a) -> String -> ()- foldString f = foldr (deepseq . f) ()+benchNF+ :: forall a b. (Bounded a, Ix a, NFData b)+ => String+ -> (a -> b)+ -> Benchmark+benchNF t f = bench t (nf (fold_ f) (minBound, maxBound)) - benchNF- :: forall a b. (Bounded a, Ix a, NFData b)- => String- -> (a -> b)- -> Benchmark- benchNF t f = bench t (nf (fold_ f) (minBound, maxBound))+fold_+ :: forall a b. (Ix a, NFData b)+ => (a -> b)+ -> (a, a)+ -> ()+fold_ f = foldr (deepseq . f) () . range - fold_- :: forall a b. (Ix a, NFData b)- => (a -> b)- -> (a, a)- -> ()- fold_ f = foldr (deepseq . f) () . range+--------------------------------------------------------------------------------+-- Characters benchmark+--------------------------------------------------------------------------------++-- | A unit benchmark+data Bench a = Bench+ { _title :: !String -- ^ Name+ , _func :: !(Char -> a) -- ^ Function to benchmark+ }++-- | Helper to compare benchmarks of function from this package to ones in base.+{-# INLINE bgroupWithValidCharRange #-}+bgroupWithValidCharRange ::+ String ->+ CharRange ->+ (Char -> Bool) ->+ (Chars -> [Benchmark]) ->+ Benchmark+bgroupWithValidCharRange groupTitle charRange isValid mkBenches =+ -- Avoid side-effects with garbage collection (see tasty-bench doc for env).+ -- We use pinned ByteArray# instead of lists to avoid that GC kicks in.+ env+ (initialize isValid charRange >>= evaluate)+ (bgroup groupTitle . mkBenches)++-- | Helper to compare benchmarks of function from this package to ones in base.+-- Filter out Surrogates, Private Use Areas and unsassigned code points.+{-# INLINE bgroupWithCharRange #-}+bgroupWithCharRange ::+ String ->+ CharRange ->+ (Chars -> [Benchmark]) ->+ Benchmark+bgroupWithCharRange title charRange =+ bgroupWithValidCharRange title charRange isValid+ where+ isValid c = S.script c /= S.Unknown++{-# INLINE benchCharsRange #-}+benchCharsRange :: NFData a => String -> String -> Chars -> (Char -> a) -> Benchmark+benchCharsRange groupTitle title chars = case title of+ "icu" -> benchCharsNF title chars+ _ -> bcompare' "icu" . benchCharsNF title chars+ where+ {-# INLINE bcompare' #-}+ -- [NOTE] Works if groupTitle uniquely identifies the benchmark group.+ bcompare' ref = bcompare+ (mconcat ["$NF == \"", ref, "\" && $(NF-1) == \"", groupTitle, "\""])++-- | Helper to compare benchmarks of function from this package to ones in base.+{-# INLINE bgroupWithChars #-}+bgroupWithChars :: (NFData a) => String -> Chars -> [Bench a] -> Benchmark+bgroupWithChars groupTitle chars bs = bgroup groupTitle+ [ benchCharsRange groupTitle title chars f+ | Bench title f <- bs+ ]++-- | Helper to bench a char function on a filtered char range+{-# INLINE benchCharsNF #-}+benchCharsNF+ :: (NFData a)+ => String+ -> Chars+ -> (Char -> a)+ -> Benchmark+benchCharsNF title chars f = bench title (nf (foldrChars f) chars)++--------------------------------------------------------------------------------+-- Chars byte array+--------------------------------------------------------------------------------++-- | Characters range+data CharRange = CharRange !Char !Char++-- | Pinned array of characters+data Chars = Chars !Exts.ByteArray# !Int++instance NFData Chars where+ rnf (Chars !_ !_) = ()++-- | Fold over a chars byte array+foldrChars :: NFData a => (Char -> a) -> Chars -> ()+foldrChars f = go+ where+ -- Loop over the pinned char array. The loop itself does not allocate.+ go (Chars cs len) = foldr+ (\(Exts.I# k) ->+ let c = Exts.indexWideCharArray# cs (k Exts.-# 1#)+#if MIN_VERSION_base(4,10,0)+ -- `inline` is necessary to avoid excessive inlining, resulting+ -- in benchmarking empty loop iterations, i.e. not the function.+ -- We could use `inline` with more care at call site, but then we+ -- would have to test the functions one by one and everytime we+ -- modify them. Using it here is a hammer but more secure and+ -- maintainable.+ -- Note that we may improve this by controling the inlining for each+ -- phase.+ in deepseq (Exts.noinline f (Exts.C# c)))+#else+ -- HACK: No `inline` for GHC < 8.2. Should we drop support?+ in deepseq (f (Exts.C# c)))+#endif+ ()+ [1..len]++-- | Create a byte array of the chars to bench+initialize :: (Char -> Bool) -> CharRange -> IO Chars+initialize isValid charRange = IO $ \s1 ->+ case Exts.newPinnedByteArray# initialLength s1 of { (# s2, ma #) ->+ -- Write the filtered char range+ case writeChars isValid ma 0# s2 start end of { (# s3, filteredCount #) ->+ -- Duplicate to get enough chars to bench+ case tile ma 0# finalLength filteredLength s3 of { s4 ->+ case Exts.unsafeFreezeByteArray# ma s4 of { (# s5, a #) ->+ (# s5, Chars a (Exts.I# (replications Exts.*# filteredCount)) #)+ }}+ where+ -- Ensure to have enough chars+ replications = case Exts.quotInt# targetCharsCount filteredCount of+ 0# -> 1#+ r# -> r#+ filteredLength = filteredCount Exts.*# wcharSize+ finalLength = filteredLength Exts.*# replications+ }}+ where+ targetCharsCount = 0x10FFFF#+ !(CharRange start end) = assert+ (ord end - ord start + 1 < Exts.I# targetCharsCount)+ charRange+ !initialLength = targetCharsCount Exts.*# wcharSize+ !(Exts.I# wcharSize) = sizeOf 'x'++-- | Write a range of chars that match the given predicate+writeChars ::+ (Char -> Bool) ->+ Exts.MutableByteArray# d ->+ Exts.Int# ->+ Exts.State# d ->+ Char ->+ Char ->+ (# Exts.State# d, Exts.Int# #)+writeChars isValid ma = go+ where+ go i s c1@(Exts.C# c1#) !c2 = if c1 < c2+ then go i' s' (succ c1) c2+ else (# s', i' #)+ where+ !(# s', i' #) = if isValid c1+ then (# Exts.writeWideCharArray# ma i c1# s, i Exts.+# 1# #)+ else (# s, i #)++-- | Duplicate a portion of an array+--+-- Adapted from Data.Text.Array.tile+tile ::+ -- | Mutable array+ Exts.MutableByteArray# s ->+ -- | Start of the portion to duplicate+ Exts.Int# ->+ -- | Total length of the duplicate+ Exts.Int# ->+ -- | Length of the portion to duplicate+ Exts.Int# ->+ Exts.State# s ->+ Exts.State# s+tile dest destOff totalLen = go+ where+ go l s+ | Exts.isTrue# ((2# Exts.*# l) Exts.># totalLen) =+ Exts.copyMutableByteArray#+ dest+ destOff+ dest+ (destOff Exts.+# l)+ (totalLen Exts.-# l)+ s+ | otherwise =+ case Exts.copyMutableByteArray#+ dest+ destOff+ dest+ (destOff Exts.+# l)+ l+ s of+ s' -> go (2# Exts.*# l) s'
lib/Unicode/Char/General/Scripts.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- -- | -- Module : Unicode.Char.General.Scripts -- Copyright : (c) 2020 Composewell Technologies and Contributors@@ -13,85 +11,91 @@ -- module Unicode.Char.General.Scripts- ( S.Script(..)+ ( -- * Unicode version+ unicodeVersion+ -- * Scripts+ , S.Script(..) , script- , scriptExtensions+ , scriptShortName , scriptDefinition+ , scriptExtensions ) where -#include "MachDeps.h"--import Data.Char (chr)-import Data.List.NonEmpty (NonEmpty)-import GHC.Exts- (Ptr(..), Char(..), Int(..),- indexWord32OffAddr#, word2Int#,- and#, isTrue#, neWord#, (-#), (<#), chr#)-#if MIN_VERSION_base(4,16,0)-import GHC.Exts (word32ToWord#)-#endif-#ifdef WORDS_BIGENDIAN-import GHC.Exts (byteSwap32#, narrow32Word#)-#endif+import qualified Data.List.NonEmpty as NE+import GHC.Exts (+ Addr#,+ Char (..),+ Int#,+ andI#,+ chr#,+ isTrue#,+ ltAddr#,+ negateInt#,+ plusAddr#,+ tagToEnum#,+ (-#),+ (<=#),+ ) -import qualified Unicode.Internal.Char.Scripts as S+import Unicode.Internal.Bits.Scripts (nextInt32#, nextInt8#, unpackCString#) import qualified Unicode.Internal.Char.ScriptExtensions as S+import qualified Unicode.Internal.Char.Scripts as S+import Unicode.Internal.Char.Scripts.Version (unicodeVersion) -- | Character [script](https://www.unicode.org/reports/tr24/). -- -- @since 0.1.0 {-# INLINE script #-} script :: Char -> S.Script-script = toEnum . S.script+script c = tagToEnum# (S.script c) +-- | Returns the 4-letter ISO 15924 code of a 'Script'.+--+-- @since 0.3.0+{-# INLINE scriptShortName #-}+scriptShortName :: S.Script -> String+scriptShortName s = unpackCString# (S.scriptShortName s)+ {- HLINT ignore scriptDefinition "Eta reduce" -} -- | Characters corresponding to a 'S.Script'. -- -- @since 0.1.0 scriptDefinition :: S.Script -> String-scriptDefinition = unpack . S.scriptDefinition- where- -- [NOTE] Encoding:- -- • A single char is encoded as an LE Word32.- -- • A range is encoded as two LE Word32 (first is lower bound, second is- -- upper bound), which correspond to the codepoints with the 32th bit set.-- scriptRangeMask# = 0x80000000## -- 1 << 31- maskComplement# = 0x7fffffff## -- 1 << 31 ^ 0xffffffff-- unpack (Ptr addr#, I# n#) = let {- getRawCodePoint k# =-#ifdef WORDS_BIGENDIAN-#if MIN_VERSION_base(4,16,0)- narrow32Word# (byteSwap32# (word32ToWord# (indexWord32OffAddr# addr# k#)));-#else- narrow32Word# (byteSwap32# (indexWord32OffAddr# addr# k#));-#endif-#elif MIN_VERSION_base(4,16,0)- word32ToWord# (indexWord32OffAddr# addr# k#);-#else- indexWord32OffAddr# addr# k#;-#endif- getCodePoint k# = word2Int# (and# maskComplement# k#);- addRange k# acc = if isTrue# (k# <# 0#)- then acc- else let {- r1# = getRawCodePoint k#;- c1# = getCodePoint r1#;- isRange = isTrue# (and# r1# scriptRangeMask# `neWord#` 0##)- } in if isRange- then let {- c2# = getCodePoint (getRawCodePoint (k# -# 1#));- acc' = foldr ((:) . chr) acc [I# c2# .. I# c1#]- } in addRange (k# -# 2#) acc'- else addRange (k# -# 1#) (C# (chr# c1#) : acc)- } in addRange (n# -# 1#) mempty+scriptDefinition s = case S.scriptDefinition s of+ (# lower#, upper#, addr0#, offset# #) -> case offset# of+ 0# -> [C# (chr# lower#)..C# (chr# upper#)]+ _ -> let {+ addr1# = addr0# `plusAddr#` offset#;+ unpack addr#+ | isTrue# (addr1# `ltAddr#` addr#) = [C# (chr# upper#)]+ | otherwise =+ let cp1# = nextInt32# addr#+ in case cp1# `andI#` S.ScriptCharMask of+ -- Range+ 0# -> foldr (:)+ (unpack (addr# `plusAddr#` 8#))+ [ C# (chr# cp1#)+ ..C# (chr# (nextInt32# (addr# `plusAddr#` 4#)))]+ -- Char+ _ -> C# (chr# (andI# S.ScriptCharMaskComplement cp1#))+ : unpack (addr# `plusAddr#` 4#)+ } in C# (chr# lower#) : unpack addr0# -- | Character -- [script extensions](https://www.unicode.org/reports/tr24/#Script_Extensions). -- -- @since 0.1.0-{-# INLINE scriptExtensions #-}-scriptExtensions :: Char -> NonEmpty S.Script-scriptExtensions = S.decodeScriptExtensions . S.scriptExtensions+scriptExtensions :: Char -> NE.NonEmpty S.Script+scriptExtensions c = case S.scriptExtensions c of+ (# n, scripts0 #)+ | isTrue# (n <=# 0#) -> tagToScript (negateInt# n) NE.:| []+ | otherwise -> tagToScript (nextInt8# scripts0)+ NE.:| go (scripts0 `plusAddr#` 1#) (n -# 1#)+ where+ tagToScript s = tagToEnum# s :: S.Script+ go :: Addr# -> Int# -> [S.Script]+ go scripts = \case+ 0# -> []+ k# -> tagToScript (nextInt8# scripts)+ : go (scripts `plusAddr#` 1#) (k# -# 1#)
+ lib/Unicode/Internal/Bits/Scripts.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Use fewer imports" #-}++-- |+-- Module : Unicode.Internal.Bits.Scripts+-- Copyright : (c) 2023 Pierre Le Marre+-- License : BSD-3-Clause+-- Maintainer : streamly@composewell.com+-- Stability : experimental+-- Portability : GHC+--+-- Fast, static bitmap lookup utilities++module Unicode.Internal.Bits.Scripts+ ( -- * Bitmap lookup+ lookupWord8AsInt#+ , lookupWord16AsInt#+ , nextInt8#+ , nextInt32#+ -- * CString+ , unpackCString#+ ) where++#include "MachDeps.h"++import GHC.Exts (+ Addr#,+ Int#,+ indexWord16OffAddr#,+ indexWord8OffAddr#,+ word2Int#,+ )++#ifdef WORDS_BIGENDIAN++import GHC.Exts (+ byteSwap16#,+ byteSwap32#,+ indexWord32OffAddr#,+ narrow16Word#,+ narrow32Word#,+ word2Int#,+ )+#if MIN_VERSION_base(4,16,0)+import GHC.Exts (word16ToWord#, word32ToWord#)+#endif++#else++import GHC.Exts (indexInt32OffAddr#)+#if MIN_VERSION_base(4,16,0)+import GHC.Exts (int32ToInt#)+#endif++#endif++#if MIN_VERSION_base(4,15,0)+import GHC.Exts (unpackCString#)+#else+import GHC.CString (unpackCString#)+#endif++#if MIN_VERSION_base(4,16,0)+import GHC.Exts (word8ToWord#, word16ToWord#)+#endif++{-| @lookupWord8AsInt# addr index@ looks up for the @index@-th @8@-bits word in+the bitmap starting at @addr@, then convert it to an 'Int'.++The caller must make sure that:++* @ceiling (addr + (n * 8))@ is legally accessible 'GHC.Exts.Word8#'.++@since 0.3.0+-}+lookupWord8AsInt#+ :: Addr# -- ^ Bitmap address+ -> Int# -- ^ Word index+ -> Int# -- ^ Resulting word as 'Int'+lookupWord8AsInt# addr# index# = word2Int#+#if MIN_VERSION_base(4,16,0)+ (word8ToWord# (indexWord8OffAddr# addr# index#))+#else+ (indexWord8OffAddr# addr# index#)+#endif++lookupWord16AsInt#+ :: Addr# -- ^ Bitmap address+ -> Int# -- ^ Word index+ -> Int# -- ^ Resulting word as `Int`+lookupWord16AsInt# addr# k# = word2Int# word##+ where+#ifdef WORDS_BIGENDIAN+#if MIN_VERSION_base(4,16,0)+ word## = narrow16Word# (byteSwap16# (word16ToWord# (indexWord16OffAddr# addr# k#)))+#else+ word## = narrow16Word# (byteSwap16# (indexWord16OffAddr# addr# k#))+#endif+#elif MIN_VERSION_base(4,16,0)+ word## = word16ToWord# (indexWord16OffAddr# addr# k#)+#else+ word## = indexWord16OffAddr# addr# k#+#endif++{-| @nextInt8# addr@ looks up for the 8-bits word in+the bitmap starting at @addr@, then convert it to an 'Int#'.++@since 0.3.0+-}+nextInt8# :: Addr# -> Int#+nextInt8# addr# = word2Int#+#if MIN_VERSION_base(4,16,0)+ (word8ToWord# (indexWord8OffAddr# addr# 0#))+#else+ (indexWord8OffAddr# addr# 0#)+#endif++{-| @nextInt32# addr@ looks up for the 32-bits word in+the bitmap starting at @addr@, then convert it to an 'Int#'.++@since 0.3.0+-}+nextInt32#+ :: Addr# -- ^ Bitmap address+ -> Int# -- ^ Resulting int+nextInt32# addr# =+#ifdef WORDS_BIGENDIAN+#if MIN_VERSION_base(4,16,0)+ word2Int# (narrow32Word# (byteSwap32# (word32ToWord# (indexWord32OffAddr# addr# 0#))))+#else+ word2Int# (narrow32Word# (byteSwap32# (indexWord32OffAddr# addr# 0#)))+#endif+#elif MIN_VERSION_base(4,16,0)+ int32ToInt# (indexInt32OffAddr# addr# 0#)+#else+ indexInt32OffAddr# addr# 0#+#endif
lib/Unicode/Internal/Char/ScriptExtensions.hs view
file too large to diff
lib/Unicode/Internal/Char/Scripts.hs view
file too large to diff
+ lib/Unicode/Internal/Char/Scripts/Version.hs view
@@ -0,0 +1,20 @@+-- DO NOT EDIT MANUALLY: autogenerated by ucd2haskell+{-# OPTIONS_HADDOCK hide #-}++-- |+-- Module : Unicode.Internal.Char.Scripts.Version+-- Copyright : (c) 2024 Composewell Technologies and Contributors+-- License : Apache-2.0+-- Maintainer : streamly@composewell.com+-- Stability : experimental++module Unicode.Internal.Char.Scripts.Version (unicodeVersion) where++import Data.Version (Version, makeVersion)++-- | Version of the Unicode standard used by this package:+-- [15.0.0](https://www.unicode.org/versions/Unicode15.0.0/).+--+-- @since 0.3.0+unicodeVersion :: Version+unicodeVersion = makeVersion [15,0,0]
+ test/ICU/ScriptsSpec.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE BlockArguments #-}++module ICU.ScriptsSpec+ ( spec+ ) where++import Data.Char (toUpper, ord)+import Data.Foldable (traverse_)+import qualified Data.List as L+import qualified Data.List.NonEmpty as NE+import Data.Maybe (isJust)+import Data.Version (versionBranch, showVersion)+import Debug.Trace (traceM)+import Numeric (showHex)+import Test.Hspec ( Spec, it, expectationFailure, shouldSatisfy )++import qualified ICU.Char as ICU+import qualified ICU.Scripts as ICU+import qualified Unicode.Char.General.Scripts as S++spec :: Spec+spec = do+ let icuScripts = (\s -> (ICU.scriptShortName s, s)) <$> [minBound..maxBound]+ it "scriptShortName"+ let check = isJust . (`lookup` icuScripts) . S.scriptShortName+ in traverse_ (`shouldSatisfy` check) [minBound..maxBound]+ it "script"+ let check c+ | s == sRef = pure ()+ | versionMismatch = traceM . mconcat $+ [ "[WARNING] Cannot test "+ , showCodePoint c+ , ": incompatible ICU version ("+ , showVersion ICU.unicodeVersion+ , " /= "+ , showVersion S.unicodeVersion+ , "). Expected "+ , show sRef+ , ", but got: "+ , show s ]+ | otherwise = expectationFailure $ mconcat+ [ show c, ": expected “", sRef, "”, got “", s, "”" ]+ where+ !s = S.scriptShortName (S.script c)+ !sRef = ICU.scriptShortName (ICU.script c)+ in traverse_ check [minBound..maxBound]+ it "scriptDefinition"+ let {+ check s =+ case lookup (S.scriptShortName s) icuScripts of+ Nothing -> error ("Cannot convert script: " ++ show s)+ Just s'+ | def == defRef -> pure ()+ | ourUnicodeVersion /= theirUnicodeVersion -> traceM . mconcat $+ [ "[WARNING] Cannot test "+ , show s+ , ": incompatible ICU version ("+ , showVersion ICU.unicodeVersion+ , " /= "+ , showVersion S.unicodeVersion+ , ")."+ , if null missing+ then ""+ else " Missing: " ++ show missing+ , "."+ , if null unexpected+ then ""+ else " Unexpected: " ++ show unexpected+ ]+ | otherwise -> expectationFailure $ mconcat+ [ show s+ , ": expected “", show def+ , "”, got “", show defRef, "”" ]+ where+ !defRef = filter ((== s') . ICU.script) [minBound..maxBound]+ !def = S.scriptDefinition s+ (missing, unexpected) = case s of+ -- No diff for “Unknown” script, lists are too big+ S.Unknown -> mempty+ _ -> (defRef L.\\ def, def L.\\ defRef)+ } in traverse_ check [minBound..maxBound]+ it "scriptExtensions"+ let check c+ | es == esRef = pure ()+ | versionMismatch = traceM . mconcat $+ [ "[WARNING] Cannot test "+ , showCodePoint c+ , ": incompatible ICU version ("+ , showVersion ICU.unicodeVersion+ , " /= "+ , showVersion S.unicodeVersion+ , "). Expected "+ , show esRef+ , ", but got: "+ , show es ]+ | otherwise = expectationFailure $ mconcat+ [ show c+ , ": expected “", show esRef+ , "”, got “", show es, "”" ]+ where+ !es = NE.sort (S.scriptShortName <$> S.scriptExtensions c)+ !esRef = NE.sort (ICU.scriptShortName <$> ICU.scriptExtensions c)+ in traverse_ check [minBound..maxBound]+ where+ ourUnicodeVersion = versionBranch S.unicodeVersion+ theirUnicodeVersion = take 3 (versionBranch ICU.unicodeVersion)+ showCodePoint c = ("U+" ++) . fmap toUpper $ showHex (ord c) ""+ versionMismatch = ourUnicodeVersion /= theirUnicodeVersion
test/Main.hs view
@@ -1,10 +1,19 @@+{-# LANGUAGE CPP #-}+ module Main where import Test.Hspec import qualified Unicode.Char.General.ScriptsSpec as Scripts+#ifdef HAS_ICU+import qualified ICU.ScriptsSpec as ICU+#endif main :: IO () main = hspec spec spec :: Spec-spec = describe "Unicode.Char.General.Scripts" Scripts.spec+spec = do+ describe "Unicode.Char.General.Scripts" Scripts.spec+#ifdef HAS_ICU+ describe "ICU.Scripts" ICU.spec+#endif
test/Unicode/Char/General/ScriptsSpec.hs view
@@ -1,28 +1,19 @@-{-# LANGUAGE BlockArguments, CPP, OverloadedLists #-}+{-# LANGUAGE BlockArguments, OverloadedLists #-} module Unicode.Char.General.ScriptsSpec ( spec ) where -#include "MachDeps.h"- import Data.Foldable (traverse_)-import Test.Hspec-import qualified Unicode.Char.General.Scripts as UScripts-import qualified Unicode.Internal.Char.Scripts as S- import GHC.Exts- (Ptr(..), Char(..), Int(..),- indexWord32OffAddr#, int2Word#,- and#, isTrue#, eqWord#, leWord#, neWord#,- andI#, (-#), (<#),- ord#)-#if MIN_VERSION_base(4,16,0)-import GHC.Exts (word32ToWord#)-#endif-#ifdef WORDS_BIGENDIAN-import GHC.Exts (byteSwap32#, narrow32Word#)-#endif+ ( isTrue#, orI#, andI#, (-#), (<#), (<=#), (==#)+ , Char (..), ord#+ , plusAddr#, eqAddr#, nullAddr#, ltAddr# )+import Test.Hspec+ ( expectationFailure, shouldBe, shouldSatisfy, it, describe, Spec )+import Unicode.Internal.Bits.Scripts (nextInt32#)+import qualified Unicode.Char.General.Scripts as S+import qualified Unicode.Internal.Char.Scripts as IS {- [NOTE] These tests may fail if the compiler’s Unicode version@@ -35,8 +26,8 @@ | 8.10.[1-4] | 4.14.{0,1} | 12.0 | | 8.10.5+ | 4.14.2+ | 13.0 | | 9.0.[1-2] | 4.15.0 | 12.1 |-| 9.2.[1-4] | 4.16.0 | 14.0 |-| 9.4.[1-2] | 4.17.0 | 14.0 |+| 9.2.[1-6] | 4.16.0 | 14.0 |+| 9.4.[1-4] | 4.17.0 | 14.0 | | 9.6.1 | 4.18.0 | 15.0 | +-------------+----------------+-----------------+ -}@@ -46,92 +37,117 @@ describe "Unicode scripts" do describe "Examples" do it "script" do- let check s = (== s) . UScripts.script- minBound `shouldSatisfy` check UScripts.Common- maxBound `shouldSatisfy` check UScripts.Unknown- '.' `shouldSatisfy` check UScripts.Common- '1' `shouldSatisfy` check UScripts.Common- 'A' `shouldSatisfy` check UScripts.Latin- 'Α' `shouldSatisfy` check UScripts.Greek -- Greek capital- 'α' `shouldSatisfy` check UScripts.Greek- '\x0300' `shouldSatisfy` check UScripts.Inherited- '\x0485' `shouldSatisfy` check UScripts.Inherited- '\x0600' `shouldSatisfy` check UScripts.Arabic- '\x060c' `shouldSatisfy` check UScripts.Common- '\x0965' `shouldSatisfy` check UScripts.Common- '\x1100' `shouldSatisfy` check UScripts.Hangul- '\x3000' `shouldSatisfy` check UScripts.Common- '\x4E00' `shouldSatisfy` check UScripts.Han- '\x11FD0' `shouldSatisfy` check UScripts.Tamil- '\x1F600' `shouldSatisfy` check UScripts.Common- '\x20000' `shouldSatisfy` check UScripts.Han+ let check s = (== s) . S.script+ minBound `shouldSatisfy` check S.Common+ maxBound `shouldSatisfy` check S.Unknown+ '.' `shouldSatisfy` check S.Common+ '1' `shouldSatisfy` check S.Common+ 'A' `shouldSatisfy` check S.Latin+ 'Α' `shouldSatisfy` check S.Greek -- Greek capital+ 'α' `shouldSatisfy` check S.Greek+ '\x0300' `shouldSatisfy` check S.Inherited+ '\x0485' `shouldSatisfy` check S.Inherited+ '\x0600' `shouldSatisfy` check S.Arabic+ '\x060c' `shouldSatisfy` check S.Common+ '\x0965' `shouldSatisfy` check S.Common+ '\x1100' `shouldSatisfy` check S.Hangul+ '\x3000' `shouldSatisfy` check S.Common+ '\x4E00' `shouldSatisfy` check S.Han+ '\x11FD0' `shouldSatisfy` check S.Tamil+ '\x1F600' `shouldSatisfy` check S.Common+ '\x20000' `shouldSatisfy` check S.Han -- BOM- '\xFEFF' `shouldSatisfy` check UScripts.Common- '\xFFFF' `shouldSatisfy` check UScripts.Unknown+ '\xFEFF' `shouldSatisfy` check S.Common+ '\xFFFF' `shouldSatisfy` check S.Unknown -- Private Use Areas- '\xE000' `shouldSatisfy` check UScripts.Unknown- '\xF0000' `shouldSatisfy` check UScripts.Unknown+ '\xE000' `shouldSatisfy` check S.Unknown+ '\xF0000' `shouldSatisfy` check S.Unknown it "scriptExtensions" do- let check s = (== s) . UScripts.scriptExtensions- minBound `shouldSatisfy` check [ UScripts.Common]- maxBound `shouldSatisfy` check [ UScripts.Unknown]- '.' `shouldSatisfy` check [ UScripts.Common]- '1' `shouldSatisfy` check [ UScripts.Common]- 'A' `shouldSatisfy` check [ UScripts.Latin]- 'Α' `shouldSatisfy` check [ UScripts.Greek]- 'α' `shouldSatisfy` check [ UScripts.Greek]- '\x0300' `shouldSatisfy` check [ UScripts.Inherited]- '\x0485' `shouldSatisfy` check [ UScripts.Cyrillic, UScripts.Latin]- '\x0600' `shouldSatisfy` check [ UScripts.Arabic]- '\x060C' `shouldSatisfy` check [ UScripts.Arabic- , UScripts.Nko- , UScripts.HanifiRohingya- , UScripts.Syriac- , UScripts.Thaana- , UScripts.Yezidi ]- '\x0965' `shouldSatisfy` check [ UScripts.Bengali- , UScripts.Devanagari- , UScripts.Dogra- , UScripts.GunjalaGondi- , UScripts.MasaramGondi- , UScripts.Grantha- , UScripts.Gujarati- , UScripts.Gurmukhi- , UScripts.Kannada- , UScripts.Limbu- , UScripts.Mahajani- , UScripts.Malayalam- , UScripts.Nandinagari- , UScripts.Oriya- , UScripts.Khudawadi- , UScripts.Sinhala- , UScripts.SylotiNagri- , UScripts.Takri- , UScripts.Tamil- , UScripts.Telugu- , UScripts.Tirhuta ]- '\x1100' `shouldSatisfy` check [ UScripts.Hangul]- '\x3001' `shouldSatisfy` check [ UScripts.Bopomofo- , UScripts.Hangul- , UScripts.Han- , UScripts.Hiragana- , UScripts.Katakana- , UScripts.Yi ]- '\x4E00' `shouldSatisfy` check [ UScripts.Han]- '\x11FD0' `shouldSatisfy` check [ UScripts.Grantha, UScripts.Tamil ]- '\x1F600' `shouldSatisfy` check [ UScripts.Common]- '\x20000' `shouldSatisfy` check [ UScripts.Han]+ let check s = (== s) . S.scriptExtensions+ minBound `shouldSatisfy` check [ S.Common]+ maxBound `shouldSatisfy` check [ S.Unknown]+ '.' `shouldSatisfy` check [ S.Common]+ '1' `shouldSatisfy` check [ S.Common]+ 'A' `shouldSatisfy` check [ S.Latin]+ 'Α' `shouldSatisfy` check [ S.Greek]+ 'α' `shouldSatisfy` check [ S.Greek]+ '\x0300' `shouldSatisfy` check [ S.Inherited]+ '\x0485' `shouldSatisfy` check [ S.Cyrillic, S.Latin]+ '\x0600' `shouldSatisfy` check [ S.Arabic]+ '\x060C' `shouldSatisfy` check [ S.Arabic+ , S.HanifiRohingya+ , S.Nko+ , S.Syriac+ , S.Thaana+ , S.Yezidi ]+ '\x0965' `shouldSatisfy` check [ S.Bengali+ , S.Devanagari+ , S.Dogra+ , S.Grantha+ , S.Gujarati+ , S.GunjalaGondi+ , S.Gurmukhi+ , S.Kannada+ , S.Khudawadi+ , S.Limbu+ , S.Mahajani+ , S.Malayalam+ , S.MasaramGondi+ , S.Nandinagari+ , S.Oriya+ , S.Sinhala+ , S.SylotiNagri+ , S.Takri+ , S.Tamil+ , S.Telugu+ , S.Tirhuta ]+ '\x1100' `shouldSatisfy` check [ S.Hangul]+ '\x3001' `shouldSatisfy` check [ S.Bopomofo+ , S.Han+ , S.Hangul+ , S.Hiragana+ , S.Katakana+ , S.Yi ]+ '\x4E00' `shouldSatisfy` check [ S.Han]+ '\x11FD0' `shouldSatisfy` check [ S.Grantha, S.Tamil ]+ '\x1F600' `shouldSatisfy` check [ S.Common]+ '\x20000' `shouldSatisfy` check [ S.Han] -- BOM- '\xFEFF' `shouldSatisfy` check [ UScripts.Common ]- '\xFFFF' `shouldSatisfy` check [ UScripts.Unknown ]+ '\xFEFF' `shouldSatisfy` check [ S.Common ]+ '\xFFFF' `shouldSatisfy` check [ S.Unknown ] -- Private Use Areas- '\xE000' `shouldSatisfy` check [ UScripts.Unknown ]- '\xF0000' `shouldSatisfy` check [ UScripts.Unknown ]+ '\xE000' `shouldSatisfy` check [ S.Unknown ]+ '\xF0000' `shouldSatisfy` check [ S.Unknown ]+ it "scriptDefinition" do+ take 304 (S.scriptDefinition S.Latin) `shouldBe`+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzªºÀÁÂÃÄÅÆÇ\+ \ÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿĀāĂ㥹Ćć\+ \ĈĉĊċČčĎďĐđĒēĔĕĖėĘęĚěĜĝĞğĠġĢģĤĥĦħĨĩĪīĬĭĮįİıIJijĴĵĶķĸĹĺĻļĽľĿŀŁłŃńŅ\+ \ņŇňʼnŊŋŌōŎŏŐőŒœŔŕŖŗŘřŚśŜŝŞşŠšŢţŤťŦŧŨũŪūŬŭŮůŰűŲųŴŵŶŷŸŹźŻżŽžſƀƁƂƃ\+ \ƄƅƆƇƈƉƊƋƌƍƎƏƐƑƒƓƔƕƖƗƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻ"+ S.scriptDefinition S.ZanabazarSquare `shouldBe`+ ['\x11A00'..'\x11A47']+ S.scriptDefinition S.Lydian `shouldBe`+ (['\x10920'..'\x10939'] <> "\x1093F")+ it "Smallest script definitions have at least one range in their bitmap"+ let {+ check s = case IS.scriptDefinition s of+ (# _, _, addr#, n# #) -> case n# of+ 0# -> isTrue# (addr# `eqAddr#` nullAddr#)+ 4# ->+ let lower = nextInt32# addr#+ upper = nextInt32# (addr# `plusAddr#` 4#)+ -- Check we have a range+ in isTrue# ((lower <# IS.ScriptCharMask) `andI#`+ (upper <# IS.ScriptCharMask) `andI#`+ (1# <# (upper -# lower)) )+ _ -> True+ } in traverse_ (`shouldSatisfy` check) (enumFromTo minBound maxBound) it "Characters are in the definition of their corresponding script" let { check c =- let s = UScripts.script c- in if s `inScript` c+ let s = S.script c+ in if c `inScript` s then pure () else expectationFailure $ mconcat [ "Char “", show c, "” in not in the definition of “"@@ -139,65 +155,56 @@ } in traverse_ check (enumFromTo minBound maxBound) it "Characters in a script definition have the corresponding script" let {- checkChar s c = let s' = UScripts.script c in if s' == s+ checkChar s c = let s' = S.script c in if s' == s then pure () else expectationFailure $ mconcat [ "Script is different for “", show c, "”. Expected: “" , show s, "” but got: “", show s', "”." ];- check s = let chars = UScripts.scriptDefinition s- in traverse_ (checkChar s) chars+ check s = case S.scriptDefinition s of+ [] -> expectationFailure $ mconcat+ ["Script “", show s, "” has an empty definition"]+ chars -> traverse_ (checkChar s) chars } in traverse_ check (enumFromTo minBound maxBound) it "Characters in with a script extension different from its script" let { check c =- let script = UScripts.script c- exts = UScripts.scriptExtensions c+ let script = S.script c+ exts = S.scriptExtensions c in if exts == pure script || (isSpecialScript script && script `notElem` exts) || (script `elem` exts) then pure () else expectationFailure (show (c, script, exts)); isSpecialScript = \case- UScripts.Common -> True- UScripts.Inherited -> True+ S.Common -> True+ S.Inherited -> True _ -> False } in traverse_ check (enumFromTo minBound maxBound) -{- HLINT ignore inScript "Eta reduce" -}--- Check if a character is in a 'S.Script'.--- This is faster than testing the string from UScripts.scriptDefinition-inScript :: S.Script -> Char -> Bool-inScript s (C# c#) = check (S.scriptDefinition s)- where- -- [NOTE] see 'scriptDefinition' for the description of the encoding.-- scriptRangeMask# = 0x80000000## -- 1 << 31- maskComplement# = 0x7fffffff## -- 1 << 31 ^ 0xffffffff- cp# = int2Word# (ord# c#)-- check (Ptr addr#, I# n#) = let {- getRawCodePoint k# =-#ifdef WORDS_BIGENDIAN-#if MIN_VERSION_base(4,16,0)- narrow32Word# (byteSwap32# (word32ToWord# (indexWord32OffAddr# addr# k#)));-#else- narrow32Word# (byteSwap32# (indexWord32OffAddr# addr# k#));-#endif-#elif MIN_VERSION_base(4,16,0)- word32ToWord# (indexWord32OffAddr# addr# k#);-#else- indexWord32OffAddr# addr# k#;-#endif- getCodePoint k# = and# maskComplement# k#;- find k# = not (isTrue# (k# <# 0#)) &&- let {- r1# = getRawCodePoint k#;- c1# = getCodePoint r1#;- isRange = isTrue# (and# r1# scriptRangeMask# `neWord#` 0##)- } in if isRange- then let {- c2# = getCodePoint (getRawCodePoint (k# -# 1#));- found = isTrue# ((c2# `leWord#` cp#) `andI#` (cp# `leWord#` c1#))- } in found || find (k# -# 2#)- else isTrue# (c1# `eqWord#` cp#) || find (k# -# 1#)- } in find (n# -# 1#)+-- | Return 'True' if a character is in a script.+-- Faster than checking scriptDefinition directly.+inScript :: Char -> S.Script -> Bool+inScript (C# c#) s = case IS.scriptDefinition s of+ (# lower#, upper#, addr0#, offset# #) ->+ case (cp# <# lower#) `orI#` (upper# <# cp#) of+ 1# -> False+ _ -> case offset# of+ 0# -> True+ _ -> isTrue# ((cp# ==# lower#) `orI#` (cp# ==# upper#))+ || check addr0#+ where+ cp# = ord# c#+ addr1# = addr0# `plusAddr#` offset#+ check addr# = case addr1# `ltAddr#` addr# of+ 1# -> False+ _ -> case nextInt32# addr# of+ cp1# -> case andI# cp1# IS.ScriptCharMask of+ -- Range+ 0# ->+ isTrue# ((cp1# <=# cp#) `andI#`+ (cp# <=# nextInt32# (addr# `plusAddr#` 4#)))+ || check (addr# `plusAddr#` 8#)+ -- Single char+ _ -> case andI# IS.ScriptCharMaskComplement cp1# -# cp# of+ 0# -> True+ _ -> check (addr# `plusAddr#` 4#)
unicode-data-scripts.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: unicode-data-scripts-version: 0.2.0.1+version: 0.3.0 synopsis: Unicode characters scripts description: @unicode-data-scripts@ provides Haskell APIs to access the Unicode@@ -26,11 +26,14 @@ , GHC==8.6.5 , GHC==8.8.4 , GHC==8.10.7- , GHC==9.0.1- , GHC==9.2.1- , GHC==9.4.2+ , GHC==9.0.2+ , GHC==9.2.8+ , GHC==9.4.8+ , GHC==9.6.5+ , GHC==9.8.2+ , GHC==9.10.1 -extra-source-files:+extra-doc-files: Changelog.md README.md @@ -50,8 +53,6 @@ LambdaCase -- Experimental, may lead to issues- DeriveAnyClass- TemplateHaskell UnboxedTuples common compile-options@@ -62,24 +63,35 @@ -fwarn-tabs default-language: Haskell2010 +flag dev-has-icu+ description: Use ICU for test and benchmark+ manual: True+ default: False+ library import: default-extensions, compile-options- default-language: Haskell2010 exposed-modules: -- The module structure is derived from -- https://www.unicode.org/reports/tr44/#Property_Index_Table Unicode.Char.General.Scripts + -- Internal files+ Unicode.Internal.Bits.Scripts+ -- Generated files -- This module structure is largely based on the UCD file names from which -- the properties are generated. Unicode.Internal.Char.Scripts Unicode.Internal.Char.ScriptExtensions+ Unicode.Internal.Char.Scripts.Version hs-source-dirs: lib build-depends:- base >= 4.7 && < 4.18- , unicode-data >= 0.4 && < 0.5+ base >= 4.7 && < 4.21+ -- Support for raw string literals unpacking is included in base ≥ 4.15+ if impl(ghc < 9.0.0)+ build-depends:+ ghc-prim >= 0.3.1 && < 1.0 test-suite test import: default-extensions, compile-options@@ -90,11 +102,15 @@ other-modules: Unicode.Char.General.ScriptsSpec build-depends:- base >= 4.7 && < 4.18- , hspec >= 2.0 && < 2.11- , unicode-data+ base >= 4.7 && < 4.21+ , hspec >= 2.0 && < 2.12 , unicode-data-scripts- default-language: Haskell2010+ if flag(dev-has-icu)+ other-modules:+ ICU.ScriptsSpec+ build-depends:+ icu+ cpp-options: -DHAS_ICU benchmark bench import: default-extensions, compile-options@@ -102,10 +118,20 @@ hs-source-dirs: bench main-is: Main.hs build-depends:- base >= 4.7 && < 4.18,- deepseq >= 1.1 && < 1.5,+ base >= 4.7 && < 4.21,+ deepseq >= 1.1 && < 1.6, tasty-bench >= 0.2.5 && < 0.4,- tasty >= 1.4.1,- unicode-data,+ tasty >= 1.4.1 && < 1.6, unicode-data-scripts- ghc-options: -O2 -fdicts-strict -rtsopts+ if impl(ghc < 9.0)+ -- Required for noinline+ build-depends: ghc-prim+ -- [NOTE] Recommendation of tasty-bench to reduce garbage collection noisiness+ ghc-options: -O2 -fdicts-strict -rtsopts -with-rtsopts=-A32m+ -- [NOTE] Recommendation of tasty-bench for comparison against baseline+ if impl(ghc >= 8.6)+ ghc-options: -fproc-alignment=64+ if flag(dev-has-icu)+ build-depends:+ icu+ cpp-options: -DHAS_ICU