diff --git a/Data/CharSet.hs b/Data/CharSet.hs --- a/Data/CharSet.hs +++ b/Data/CharSet.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, CPP #-} +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.CharSet @@ -6,532 +6,240 @@ -- License : BSD3 -- Maintainer : ekmett@gmail.com -- Stability : experimental --- Portability : portable +-- Portability : portable (CPP) -- --- Encode unicode character sets as arbitrary precision floating point values --- using the least character in the set as the exponent. Can efficiently represent --- reasonably tightly grouped character sets, but may use up to 139KiB to represent --- a particularly sparse set. --- +-- Fast complementable character sets +-- -- Designed to be imported qualified: -- -- > import Data.CharSet (CharSet) -- > import qualified Data.CharSet as CharSet ------------------------------------------------------------------------------- -module Data.CharSet +module Data.CharSet ( - -- * CharSet + -- * Set type CharSet + -- * Operators + , (\\) + -- * Query + , null + , size + , member + , notMember + , overlaps, isSubsetOf + , isComplemented + -- * Construction , build - -- * Manipulation , empty , singleton , full - , union - , intersection - , complement , insert , delete - , (\\) + , complement + , range + -- * Combine + , union + , intersection + , difference + -- * Filter + , filter + , partition + -- * Map + , map + -- * Fold + , fold + -- * Conversion + -- ** List + , toList , fromList + -- ** Ordered list + , toAscList + , fromAscList , fromDistinctAscList + -- ** IntMaps + , fromCharSet + , toCharSet + -- ** Array , toArray - -- * Accessors - , null - , size - , member - , elem - , notElem - , isComplemented - , toInteger - -- * Builtins - -- ** POSIX - , posixAscii - -- ** Unicode - , UnicodeCategory(..) - , unicodeCategories - -- ** Data.Char classifiers - , control, space, lower, upper, alpha, alphaNum - , print, digit, octDigit, letter, mark, number - , punctuation, symbol, separator, ascii, latin1, asciiUpper, asciiLower ) where -import Data.Array hiding (range) -import qualified Data.Bits as Bits -import Data.Bits hiding (complement) -import Data.Char +import Data.Array.Unboxed hiding (range) import Data.Data import Data.Function (on) -import Data.Map (Map) -import qualified Data.Map as Map +import Data.IntSet (IntSet) import Data.Monoid (Monoid(..)) -import Prelude hiding (null, exponent, toInteger, elem, notElem, print, pi) +import qualified Data.IntSet as I +import qualified Data.List as L +import Prelude hiding (filter, map, null) +import qualified Prelude as P import Text.Read -data CharSet = CS - { _countAtLeast :: {-# UNPACK #-} !Int -- ^ A conservative upper bound on the element count. - -- If negative, we are complemented with respect to the universe - , _countAtMost :: {-# UNPACK #-} !Int -- ^ A conservative lower bound on the element count. - -- If negative, we are complemented with respect to the universe - , _count :: Int -- ^ Lazy element count used when the above two disagree. O(1) environment size - , exponent :: {-# UNPACK #-} !Int -- ^ Low water mark. index of the least element potentially in the set. - , _hwm :: {-# UNPACK #-} !Int -- ^ High water mark. index of the greatest element potentially in the set. - , mantissa :: {-# UNPACK #-} !Integer -- ^ the set of bits starting from the exponent. - -- if negative, then we are complemented with respect to universe - } +data CharSet = P IntSet | N IntSet +(\\) :: CharSet -> CharSet -> CharSet +(\\) = difference -ul, uh :: Char -ul = minBound -uh = maxBound -{-# INLINE ul #-} -{-# INLINE uh #-} +build :: (Char -> Bool) -> CharSet +build p = fromDistinctAscList $ P.filter p [minBound .. maxBound] +{-# INLINE build #-} -ol, oh :: Int -ol = fromEnum ul -oh = fromEnum uh -{-# INLINE ol #-} -{-# INLINE oh #-} +map :: (Char -> Char) -> CharSet -> CharSet +map f (P i) = P (I.map (fromEnum . f . toEnum) i) +map f (N i) = fromList $ P.map f $ P.filter (\x -> fromEnum x `I.notMember` i) [ul..uh] +{-# INLINE map #-} --- | Internal smart constructor. Forces count whenever it is pigeonholed. -bs :: Int -> Int -> Int -> Int -> Int -> Integer -> CharSet -bs !a !b c !l !h !m | a == b = CS a a a l h m - | otherwise = CS a b c l h m -{-# INLINE bs #-} +isComplemented :: CharSet -> Bool +isComplemented (P _) = False +isComplemented (N _) = True +{-# INLINE isComplemented #-} --- | /O(d)/ where /d/ is absolute deviation in fromEnum over the set toList :: CharSet -> String -toList (CS _ _ _ l h m) - | m < 0 = map toEnum [ol..max (pred l) ol] ++ toList' l (map toEnum [min (succ h) oh..oh]) - | otherwise = toList' 0 [] - where - toList' :: Int -> String -> String - toList' !n t | n > h = t - | testBit m (n - l) = toEnum n : toList' (n+1) t - | otherwise = toList' (n+1) t +toList (P i) = P.map toEnum (I.toList i) +toList (N i) = P.filter (\x -> fromEnum x `I.notMember` i) [ul..uh] {-# INLINE toList #-} --- | /O(1)/ The empty set. Permits /O(1)/ null and size. +toAscList :: CharSet -> String +toAscList (P i) = P.map toEnum (I.toAscList i) +toAscList (N i) = P.filter (\x -> fromEnum x `I.notMember` i) [ul..uh] +{-# INLINE toAscList #-} + empty :: CharSet -empty = CS 0 0 0 0 0 0 +empty = P I.empty {-# INLINE empty #-} --- | /O(1)/ Construct a @CharSet@ with a single element. Permits /O(1)/ null and size -singleton :: Char -> CharSet -singleton x = CS 1 1 1 e e 1 where e = fromEnum x +singleton :: Char -> CharSet +singleton = P . I.singleton . fromEnum {-# INLINE singleton #-} --- | /O(1|d)/ Is the 'CharSet' empty? May be faster than checking if @'size' == 0@ after union. --- Operations that require a recount are noted. +full :: CharSet +full = N I.empty +{-# INLINE full #-} + null :: CharSet -> Bool -null (CS a b c _ _ _) - | a > 0 = False - | b == 0 = True - | otherwise = c == 0 +null (P i) = I.null i +null (N i) = I.size i == numChars -- badly normalized! {-# INLINE null #-} --- | /O(1|d)/ The number of elements in the bit set. size :: CharSet -> Int -size (CS a b c _ _ m) - | (a == b) && (m >= 0) = a - | a == b = oh - ol - a - | m >= 0 = c - | otherwise = oh - ol - c +size (P i) = I.size i +size (N i) = numChars - I.size i {-# INLINE size #-} --- | /O(d)/ A 'CharSet' containing every member of the enumeration of @a@. -full :: CharSet -full = complement empty -{-# INLINE full #-} - --- | /O(d)/ Complements a 'CharSet' with respect to the bounds of @a@. Preserves order of 'null' and 'size' -complement :: CharSet -> CharSet -complement (CS a b c l h m) = CS (Bits.complement b) (Bits.complement a) (Bits.complement c) l h (Bits.complement m) -{-# INLINE complement #-} - --- | /O(d * n)/ Make a 'CharSet' from a list of items. -fromList :: String -> CharSet -fromList = foldr insert empty -{-# INLINE fromList #-} - --- | /O(d * n)/ Make a 'CharSet' from a distinct ascending list of items -fromDistinctAscList :: String -> CharSet -fromDistinctAscList [] = empty -fromDistinctAscList (c:cs) = fromDistinctAscList' cs 1 0 1 - where - l = fromEnum c - fromDistinctAscList' :: String -> Int -> Int -> Integer -> CharSet - fromDistinctAscList' [] !n !h !m = CS n n n l h m - fromDistinctAscList' (c':cs') !n _ !m = fromDistinctAscList' cs' (n+1) h' (setBit m (h' - l)) - where - h' = fromEnum c' -{-# INLINE fromDistinctAscList #-} - --- | /O(d)/ Insert a single element of type @a@ into the 'CharSet'. Preserves order of 'null' and 'size' insert :: Char -> CharSet -> CharSet -insert x r@(CS a b c l h m) - | (m < 0) && (e < l) = r - | (m < 0) && (e > h) = r - | e < l = bs (a+1) (b+1) (c+1) e h (shiftL m (l - e) .|. 1) - | e > h = bs (a+1) (b+1) (c+1) l p (setBit m p) - | testBit m p = r - | otherwise = bs (a+1) (b+1) (c+1) l h (setBit m p) - where - e = fromEnum x - p = e - l +insert c (P i) = P (I.insert (fromEnum c) i) +insert c (N i) = P (I.delete (fromEnum c) i) {-# INLINE insert #-} --- | /O(d)/ Delete a single item from the 'CharSet'. Preserves order of 'null' and 'size' +range :: Char -> Char -> CharSet +range a b + | a <= b = fromDistinctAscList [a..b] + | otherwise = empty + delete :: Char -> CharSet -> CharSet -delete x r@(CS a b c l h m) - | (m < 0) && (e < l) = bs (a+1) (b+1) (c+1) e h (shiftL m (l - e) .&. Bits.complement 1) - | (m < 0) && (e > h) = bs (a+1) (b+1) (c+1) l p (clearBit m p) - | e < l = r - | e > h = r - | testBit m p = bs (a-1) (b-1) (c-1) l h (clearBit m p) - | otherwise = r - where - e = fromEnum x - p = e - l +delete c (P i) = P (I.delete (fromEnum c) i) +delete c (N i) = N (I.insert (fromEnum c) i) {-# INLINE delete #-} --- | /O(1)/ Test for membership in a 'CharSet' -member :: Char -> CharSet -> Bool -member x (CS _ _ _ l h m) - | e < l = m < 0 - | e > h = m > 0 - | otherwise = testBit m (e - l) - where - e = fromEnum x -{-# INLINE member #-} - -{- -notMember :: Char -> CharSet -> Bool -notMember x - not . member x -{-# INLINE notMember #-} --} - --- | /O(1)/ Alias for member -elem :: Char -> CharSet -> Bool -elem = member -{-# INLINE elem #-} - --- | /O(1)/ Alias for notMember -notElem :: Char -> CharSet -> Bool -notElem x = not . elem x -{-# INLINE notElem #-} - --- | /O(d)/ convert to an Integer representation. Discards negative elements -toInteger :: CharSet -> Integer -toInteger x = mantissa x `shift` exponent x -{-# INLINE toInteger #-} +complement :: CharSet -> CharSet +complement (P i) = N i +complement (N i) = P i +{-# INLINE complement #-} --- | /O(d)/. May force 'size' to take /O(d)/ if ranges overlap, preserves order of 'null' -union :: CharSet -> CharSet -> CharSet -union x@(CS _ _ _ l _ _) y@(CS _ _ _ l' _ _) - | l' < l = union' y x -- ensure left side has lower exponent - | otherwise = union' x y +union :: CharSet -> CharSet -> CharSet +union (P i) (P j) = P (I.union i j) +union (P i) (N j) = N (I.difference j i) +union (N i) (P j) = N (I.difference i j) +union (N i) (N j) = N (I.intersection i j) {-# INLINE union #-} -union' :: CharSet -> CharSet -> CharSet -union' x@(CS a b c l h m) y@(CS a' b' c' l' h' m') - | b == 0 = y -- fast empty union - | b' == 0 = x -- fast empty union - | a == -1 = full -- fast full union - | a' == -1 = full -- fast full union - | (m < 0) && (m' < 0) = complement (intersection' (complement x) (complement y)) -- appeal to intersection - | m' < 0 = complement (diff (complement y) x) -- union with complement - | m < 0 = complement (diff (complement x) y) -- union with complement - | h < l' = bs (a + a') (b + b') (c + c') l h' m'' -- disjoint positive ranges - | otherwise = bs (a `max` a') (b + b') (recount m'') l (h `max` h') m'' -- overlapped positives - where - m'' = m .|. shiftL m' (l' - l) - --- | /O(1)/ check to see if we are represented as a complemented 'CharSet'. -isComplemented :: CharSet -> Bool -isComplemented = (<0) . mantissa -{-# INLINE isComplemented #-} - --- | /O(d)/. May force 'size' and 'null' both to take /O(d)/. -intersection :: CharSet -> CharSet -> CharSet -intersection x@(CS _ _ _ l _ _) y@(CS _ _ _ l' _ _) - | l' < l = intersection' y x - | otherwise = intersection' x y +intersection :: CharSet -> CharSet -> CharSet +intersection (P i) (P j) = P (I.intersection i j) +intersection (P i) (N j) = P (I.difference i j) +intersection (N i) (P j) = P (I.difference j i) +intersection (N i) (N j) = N (I.union i j) {-# INLINE intersection #-} --- | /O(d)/. May force 'size' and 'null' both to take /O(d)/. -intersection' :: CharSet -> CharSet -> CharSet -intersection' x@(CS a b _ l h m) y@(CS a' b' _ l' h' m') - | b == 0 = empty - | b' == 0 = empty - | a == -1 = y - | a' == -1 = x - | (m < 0) && (m' < 0) = complement (union' (complement x) (complement y)) - | m' < 0 = diff x (complement y) - | m < 0 = diff y (complement x) - | h < l' = empty - | otherwise = bs 0 (b `min` b') (recount m'') l'' (h `min` h') m'' - where - l'' = max l l' - m'' = shift m (l'' - l) .&. shift m' (l'' - l') - --- | Unsafe internal method for computing differences --- preconditions: --- m >= 0, m' >= 0, a /= -1, a' /= -1, b /= 0, b' /= 0 -diff :: CharSet -> CharSet -> CharSet -diff x@(CS a _ _ l h m) (CS _ b' _ l' h' m') - | h < l' = x - | h' < l = x - | otherwise = bs (max (a - b') 0) a (recount m'') l h m'' - where - m'' = m .&. shift (Bits.complement m') (l' - l) - --- | /O(d)/. Preserves order of 'null'. May force /O(d)/ 'size'. difference :: CharSet -> CharSet -> CharSet -difference x@(CS a b _ _ _ m) y@(CS a' b' _ _ _ m') - | a == -1 = complement y - | a' == -1 = empty - | b == 0 = empty - | b' == 0 = x - | (m < 0) && (m' < 0) = diff (complement y) (complement x) - | m < 0 = complement (complement x `union` y) - | m' < 0 = x `union` complement y - | otherwise = diff x y - --- | /O(d)/. Preserves order of 'null'. May force /O(d)/ 'size'. -(\\) :: CharSet -> CharSet -> CharSet -(\\) = difference - -instance Eq CharSet where - x@(CS _ _ _ l _ m) == y@(CS _ _ _ l' _ m') - | signum m == signum m' = shift m (l - l'') == shift m' (l - l'') - | m' < 0 = y == x - | otherwise = mask .&. shift m (l - ol) == shift m' (l - ol) - where - l'' = min l l' - mask = setBit 0 (oh - ol + 1) - 1 +difference (P i) (P j) = P (I.difference i j) +difference (P i) (N j) = P (I.intersection i j) +difference (N i) (P j) = N (I.union i j) +difference (N i) (N j) = P (I.difference j i) +{-# INLINE difference #-} -instance Ord CharSet where - compare = compare `on` toInteger +member :: Char -> CharSet -> Bool +member c (P i) = I.member (fromEnum c) i +member c (N i) = I.notMember (fromEnum c) i +{-# INLINE member #-} -instance Bounded CharSet where - minBound = empty - maxBound = CS n n n ol oh m - where - n = oh - ol + 1 - m = setBit 0 n - 1 +notMember :: Char -> CharSet -> Bool +notMember c (P i) = I.notMember (fromEnum c) i +notMember c (N i) = I.member (fromEnum c) i +{-# INLINE notMember #-} --- | Return a charset based on a character range -range :: Char -> Char -> CharSet -range l h - | l <= h = CS n n n l' h' m - | otherwise = empty - where - l' = fromEnum l - h' = fromEnum h - n = h' - l' + 1 - m = setBit 0 n - 1 +fold :: (Char -> b -> b) -> b -> CharSet -> b +fold f z (P i) = I.fold (f . toEnum) z i +fold f z (N i) = foldr f z $ P.filter (\x -> fromEnum x `I.notMember` i) [ul..uh] +{-# INLINE fold #-} --- | /O(d)/ -recount :: Integer -> Int -recount !n - | n < 0 = Bits.complement (recount (Bits.complement n)) - | otherwise = recount' 0 0 - where - h = hwm n - recount' !i !c - | i > h = c - | otherwise = recount' (i+1) (if testBit n i then c+1 else c) +filter :: (Char -> Bool) -> CharSet -> CharSet +filter p (P i) = P (I.filter (p . toEnum) i) +filter p (N i) = N $ foldr (I.insert) i $ P.filter (\x -> (x `I.notMember` i) && not (p (toEnum x))) [ol..oh] +{-# INLINE filter #-} --- | /O(d)/. Computes the equivalent of (truncate . logBase 2 . abs) extended with 0 at 0 --- This could be computed faster by directly appealing to GMP, but that is tricky in GHC. -hwm :: Integer -> Int -hwm !n - | n < 0 = hwm (-n) - | n > 1 = scan p (2*p) - | otherwise = 0 - where - p = probe 1 - -- incrementally compute 2^(2^(i+1)) until it exceeds n - probe :: Int -> Int - probe !i - | bit (2*i) > n = i - | otherwise = probe (2*i) +partition :: (Char -> Bool) -> CharSet -> (CharSet, CharSet) +partition p (P i) = (P l, P r) + where (l,r) = I.partition (p . toEnum) i +partition p (N i) = (N (foldr I.insert i l), N (foldr I.insert i r)) + where (l,r) = L.partition (p . toEnum) $ P.filter (\x -> x `I.notMember` i) [ol..oh] +{-# INLINE partition #-} - -- then binary search the powers for the highest set bit - scan :: Int -> Int -> Int - scan !l !h - | l == h = l - | bit (m+1) > n = scan l m - | otherwise = scan (m+1) h - where m = l + (h - l) `div` 2 +overlaps :: CharSet -> CharSet -> Bool +overlaps (P i) (P j) = not (I.null (I.intersection i j)) +overlaps (P i) (N j) = not (I.isSubsetOf j i) +overlaps (N i) (P j) = not (I.isSubsetOf i j) +overlaps (N i) (N j) = any (\x -> I.notMember x i && I.notMember x j) [ol..oh] -- not likely +{-# INLINE overlaps #-} -toArray :: CharSet -> Array Char Bool -toArray set = array (minBound, maxBound) $ fmap (\x -> (x, x `elem` set)) [minBound .. maxBound] - -instance Show CharSet where - showsPrec d x@(CS _ _ _ _ _ m) - | m < 0 = showParen (d > 10) $ showString "complement " . showsPrec 11 (complement x) - | otherwise = showParen (d > 10) $ showString "fromDistinctAscList " . showsPrec 11 (toList x) +isSubsetOf :: CharSet -> CharSet -> Bool +isSubsetOf (P i) (P j) = I.isSubsetOf i j +isSubsetOf (P i) (N j) = I.null (I.intersection i j) +isSubsetOf (N i) (P j) = all (\x -> I.member x i && I.member x j) [ol..oh]-- not bloody likely +isSubsetOf (N i) (N j) = I.isSubsetOf j i +{-# INLINE isSubsetOf #-} +fromList :: String -> CharSet +fromList = P . I.fromList . P.map fromEnum +{-# INLINE fromList #-} -instance Read CharSet where -#ifdef __GLASGOW_HASKELL__ - readPrec = parens $ complemented +++ normal - where - complemented = prec 10 $ do - Ident "complement" <- lexP - complement `fmap` step readPrec - normal = prec 10 $ do - Ident "fromDistinctAscList" <- lexP - fromDistinctAscList `fmap` step readPrec -#else - readsPrec d r = - readParen (d > 10) (\r -> [ (complement m, t) - | ("complement", s) <- lex r - , (m, t) <- readsPrec 11 s]) r - ++ readParen (d > 10) (\r -> [ (fromDistinctAscList m, t) - | ("fromDistinctAscList", s) <- lex r - , (m, t) <- readsPrec 11 s]) r -#endif +fromAscList :: String -> CharSet +fromAscList = P . I.fromAscList . P.map fromEnum +{-# INLINE fromAscList #-} -instance Monoid CharSet where - mempty = empty - mappend = union +fromDistinctAscList :: String -> CharSet +fromDistinctAscList = P . I.fromDistinctAscList . P.map fromEnum +{-# INLINE fromDistinctAscList #-} -build :: (Char -> Bool) -> CharSet -build p = fromDistinctAscList $ filter p [minBound .. maxBound] +-- isProperSubsetOf :: CharSet -> CharSet -> Bool +-- isProperSubsetOf (P i) (P j) = I.isProperSubsetOf i j +-- isProperSubsetOf (P i) (N j) = null (I.intersection i j) && ... +-- isProperSubsetOf (N i) (N j) = I.isProperSubsetOf j i --- :digit:, etc. -posixAscii :: Map String CharSet -posixAscii = Map.fromList - [ ("alnum", alnum') - , ("alpha", alpha') - , ("blank", fromList " \t") - , ("cntrl", insert '\x7f' $ range '\x00' '\x1f') - , ("digit", digit') - , ("graph", range '\x21' '\x7e') - , ("print", range '\x20' '\x7e') - , ("word", insert '_' alnum') - , ("punct", fromList "-!\"#$%&'()*+,./:;<=>?@[\\]^_`{|}~") - , ("space", fromList " \t\r\n\v\f") - , ("upper", upper') - , ("lower", lower') - , ("xdigit", digit `union` range 'a' 'f' `union` range 'A' 'F') - ] - where - lower' = range 'a' 'z' - upper' = range 'A' 'Z' - alpha' = lower' `union` upper' - digit' = range '0' '9' - alnum' = alpha' `union` digit' +ul, uh :: Char +ul = minBound +uh = maxBound +{-# INLINE ul #-} +{-# INLINE uh #-} -data UnicodeCategory = UnicodeCategory String String CharSet String +ol, oh :: Int +ol = fromEnum ul +oh = fromEnum uh +{-# INLINE ol #-} +{-# INLINE oh #-} --- \p{Letter} or \p{Mc} -unicodeCategories :: [UnicodeCategory] -unicodeCategories = - [ UnicodeCategory "Letter" "L" l "any kind of letter from any language." - , UnicodeCategory "Lowercase_Letter" "Ll" ll "a lowercase letter that has an uppercase variant" - , UnicodeCategory "Uppercase_Letter" "Lu" lu "an uppercase letter that has a lowercase variant" - , UnicodeCategory "Titlecase_Letter" "Lt" lt "a letter that appears at the start of a word when only the first letter of the word is capitalized" - , UnicodeCategory "Letter&" "L&" la "a letter that exists in lowercase and uppercase variants (combination of Ll, Lu and Lt)" - , UnicodeCategory "Modifier_Letter" "Lm" lm "a special character that is used like a letter" - , UnicodeCategory "Other_Letter" "Lo" lo "a letter or ideograph that does not have lowercase and uppercase variants" - , UnicodeCategory "Mark" "M" m "a character intended to be combined with another character (e.g. accents, umlauts, enclosing boxes, etc.)" - , UnicodeCategory "Non_Spacing_Mark" "Mn" mn "a character intended to be combined with another character without taking up extra space (e.g. accents, umlauts, etc.)" - , UnicodeCategory "Spacing_Combining_Mark" "Mc" mc "a character intended to be combined with another character that takes up extra space (vowel signs in many Eastern languages)" - , UnicodeCategory "Enclosing_Mark" "Me" me "a character that encloses the character is is combined with (circle, square, keycap, etc.)" - , UnicodeCategory "Separator" "Z" z "any kind of whitespace or invisible separator" - , UnicodeCategory "Space_Separator" "Zs" zs "a whitespace character that is invisible, but does take up space" - , UnicodeCategory "Line_Separator" "Zl" zl "line separator character U+2028" - , UnicodeCategory "Paragraph_Separator" "Zp" zp "paragraph separator character U+2029" - , UnicodeCategory "Symbol" "S" s "math symbols, currency signs, dingbats, box-drawing characters, etc." - , UnicodeCategory "Math_Symbol" "Sm" sm "any mathematical symbol" - , UnicodeCategory "Currency_Symbol" "Sc" sc "any currency sign" - , UnicodeCategory "Modifier_Symbol" "Sk" sk "a combining character (mark) as a full character on its own" - , UnicodeCategory "Other_Symbol" "So" so "various symbols that are not math symbols, currency signs, or combining characters" - , UnicodeCategory "Number" "N" n "any kind of numeric character in any script" - , UnicodeCategory "Decimal_Digit_Number" "Nd" nd "a digit zero through nine in any script except ideographic scripts" - , UnicodeCategory "Letter_Number" "Nl" nl "a number that looks like a letter, such as a Roman numeral" - , UnicodeCategory "Other_Number" "No" no "a superscript or subscript digit, or a number that is not a digit 0..9 (excluding numbers from ideographic scripts)" - , UnicodeCategory "Punctuation" "P" p "any kind of punctuation character" - , UnicodeCategory "Dash_Punctuation" "Pd" pd "any kind of hyphen or dash" - , UnicodeCategory "Open_Punctuation" "Ps" ps "any kind of opening bracket" - , UnicodeCategory "Close_Punctuation" "Pe" pe "any kind of closing bracket" - , UnicodeCategory "Initial_Punctuation" "Pi" pi "any kind of opening quote" - , UnicodeCategory "Final_Punctuation" "Pf" pf "any kind of closing quote" - , UnicodeCategory "Connector_Punctuation" "Pc" pc "a punctuation character such as an underscore that connects words" - , UnicodeCategory "Other_Punctuation" "Po" po "any kind of punctuation character that is not a dash, bracket, quote or connector" - , UnicodeCategory "Other" "C" c "invisible control characters and unused code points" - , UnicodeCategory "Control" "Cc" cc "an ASCII 0x00..0x1F or Latin-1 0x80..0x9F control character" - , UnicodeCategory "Format" "Cf" cf "invisible formatting indicator" - , UnicodeCategory "Private_Use" "Co" co "any code point reserved for private use" - , UnicodeCategory "Surrogate" "Cs" cs "one half of a surrogate pair in UTF-16 encoding" - , UnicodeCategory "Unassigned" "Cn" cn "any code point to which no character has been assigned.properties" ] - where - cat category = build ((category ==) . generalCategory) - ll = cat LowercaseLetter - lu = cat UppercaseLetter - lt = cat TitlecaseLetter - la = ll `union` lu `union` lt - lm = cat ModifierLetter - lo = cat OtherLetter - l = la `union` lm `union` lo - mn = cat NonSpacingMark - mc = cat SpacingCombiningMark - me = cat EnclosingMark - m = mn `union` mc `union` me - zs = cat Space - zl = cat LineSeparator - zp = cat ParagraphSeparator - z = zs `union` zl `union` zp - sm = cat MathSymbol - sc = cat CurrencySymbol - sk = cat ModifierSymbol - so = cat OtherSymbol - s = sm `union` sc `union` sk `union` so - nd = cat DecimalNumber - nl = cat LetterNumber - no = cat OtherNumber - n = nd `union` nl `union` no - pd = cat DashPunctuation - ps = cat OpenPunctuation - pe = cat ClosePunctuation - pi = cat InitialQuote - pf = cat FinalQuote - pc = cat ConnectorPunctuation - po = cat OtherPunctuation - p = pd `union` ps `union` pe `union` pi `union` pf `union` pc `union` po - cc = cat Control - cf = cat Format - co = cat PrivateUse - cs = cat Surrogate - cn = cat NotAssigned - c = cc `union` cf `union` co `union` cs `union` cn - --- Haskell character classes from Data.Char -control, space, lower, upper, alpha, alphaNum, print, digit, octDigit, letter, mark, number, punctuation, symbol, separator, ascii, latin1, asciiUpper, asciiLower :: CharSet -control = build isControl -space = build isSpace -lower = build isLower -upper = build isUpper -alpha = build isAlpha -alphaNum = build isAlphaNum -print = build isPrint -digit = build isDigit -octDigit = build isOctDigit -letter = build isLetter -mark = build isMark -number = build isNumber -punctuation = build isPunctuation -symbol = build isSymbol -separator = build isSeparator -ascii = build isAscii -latin1 = build isLatin1 -asciiUpper = build isAsciiUpper -asciiLower = build isAsciiLower +numChars :: Int +numChars = oh - ol + 1 +{-# INLINE numChars #-} instance Typeable CharSet where typeOf _ = mkTyConApp charSetTyCon [] @@ -543,6 +251,7 @@ instance Data CharSet where gfoldl k z set | isComplemented set = z complement `k` complement set | otherwise = z fromList `k` toList set + toConstr set | isComplemented set = complementConstr | otherwise = fromListConstr @@ -553,7 +262,7 @@ 1 -> k (z fromList) 2 -> k (z complement) _ -> error "gunfold" - + fromListConstr :: Constr fromListConstr = mkConstr charSetDataType "fromList" [] Prefix {-# NOINLINE fromListConstr #-} @@ -565,3 +274,55 @@ charSetDataType :: DataType charSetDataType = mkDataType "Data.CharSet.CharSet" [fromListConstr, complementConstr] {-# NOINLINE charSetDataType #-} + +-- returns an intset and if the intset should be complemented to obtain the contents of the CharSet +fromCharSet :: CharSet -> (Bool, IntSet) +fromCharSet (P i) = (False, i) +fromCharSet (N i) = (True, i) +{-# INLINE fromCharSet #-} + +toCharSet :: IntSet -> CharSet +toCharSet = P +{-# INLINE toCharSet #-} + +instance Eq CharSet where + (==) = (==) `on` toAscList + +instance Ord CharSet where + compare = compare `on` toAscList + +instance Bounded CharSet where + minBound = empty + maxBound = full + +toArray :: CharSet -> UArray Char Bool +toArray set = array (minBound, maxBound) $ fmap (\x -> (x, x `member` set)) [minBound .. maxBound] + +instance Show CharSet where + showsPrec d i + | isComplemented i = showParen (d > 10) $ showString "complement " . showsPrec 11 (complement i) + | otherwise = showParen (d > 10) $ showString "fromDistinctAscList " . showsPrec 11 (toAscList i) + +instance Read CharSet where +#ifdef __GLASGOW_HASKELL__ + readPrec = parens $ complemented +++ normal + where + complemented = prec 10 $ do + Ident "complement" <- lexP + complement `fmap` step readPrec + normal = prec 10 $ do + Ident "fromDistinctAscList" <- lexP + fromDistinctAscList `fmap` step readPrec +#else + readsPrec d r = + readParen (d > 10) (\r -> [ (complement m, t) + | ("complement", s) <- lex r + , (m, t) <- readsPrec 11 s]) r + ++ readParen (d > 10) (\r -> [ (fromDistinctAscList m, t) + | ("fromDistinctAscList", s) <- lex r + , (m, t) <- readsPrec 11 s]) r +#endif + +instance Monoid CharSet where + mempty = empty + mappend = union diff --git a/Data/CharSet/Common.hs b/Data/CharSet/Common.hs new file mode 100644 --- /dev/null +++ b/Data/CharSet/Common.hs @@ -0,0 +1,65 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.CharSet.Common +-- Copyright : (c) Edward Kmett 2010 +-- License : BSD3 +-- Maintainer : ekmett@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- The various character classifications from "Data.Char" as 'CharSet's +------------------------------------------------------------------------------- + +module Data.CharSet.Common + ( + -- ** Data.Char classes + control + , space + , lower + , upper + , alpha + , alphaNum + , print + , digit + , octDigit + , letter + , mark + , number + , punctuation + , symbol + , separator + , ascii + , latin1 + , asciiUpper + , asciiLower + ) where + +import Prelude () +import Data.Char +import Data.CharSet + +-- Haskell character classes from Data.Char +control, space, lower, upper, alpha, alphaNum, + print, digit, octDigit, letter, mark, number, + punctuation, symbol, separator, ascii, latin1 + , asciiUpper, asciiLower :: CharSet + +control = build isControl +space = build isSpace +lower = build isLower +upper = build isUpper +alpha = build isAlpha +alphaNum = build isAlphaNum +print = build isPrint +digit = build isDigit +octDigit = build isOctDigit +letter = build isLetter +mark = build isMark +number = build isNumber +punctuation = build isPunctuation +symbol = build isSymbol +separator = build isSeparator +ascii = build isAscii +latin1 = build isLatin1 +asciiUpper = build isAsciiUpper +asciiLower = build isAsciiLower diff --git a/Data/CharSet/Posix/Ascii.hs b/Data/CharSet/Posix/Ascii.hs new file mode 100644 --- /dev/null +++ b/Data/CharSet/Posix/Ascii.hs @@ -0,0 +1,54 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.CharSet.Posix.Ascii +-- Copyright : (c) Edward Kmett 2010 +-- License : BSD3 +-- Maintainer : ekmett@gmail.com +-- Stability : experimental +-- Portability : portable +-- +------------------------------------------------------------------------------- + +module Data.CharSet.Posix.Ascii + ( posixAscii + -- * POSIX ASCII \"classes\" + , alnum, alpha, blank, cntrl, digit, graph, print, word, punct, space, upper, lower, xdigit + ) where + +import Prelude hiding (print) +import Data.CharSet +import Data.Map (Map) +import qualified Data.Map as Map + +alnum, alpha, blank, cntrl, digit, graph, print, word, punct, space, upper, lower, xdigit :: CharSet +alnum = alpha `union` digit +alpha = lower `union` upper +blank = fromList " \t" +cntrl = insert '\x7f' $ range '\x00' '\x1f' +digit = range '0' '9' +lower = range 'a' 'z' +upper = range 'A' 'Z' +graph = range '\x21' '\x7e' +print = insert '\x20' graph +word = insert '_' alnum +punct = fromList "-!\"#$%&'()*+,./:;<=>?@[\\]^_`{|}~" +space = fromList " \t\r\n\v\f" +xdigit = digit `union` range 'a' 'f' `union` range 'A' 'F' + +-- :digit:, etc. +posixAscii :: Map String CharSet +posixAscii = Map.fromList + [ ("alnum", alnum) + , ("alpha", alpha) + , ("blank", blank) + , ("cntrl", cntrl) + , ("digit", digit) + , ("graph", graph) + , ("print", print) + , ("word", word) + , ("punct", punct) + , ("space", space) + , ("upper", upper) + , ("lower", lower) + , ("xdigit", xdigit) + ] diff --git a/Data/CharSet/Unicode.hs b/Data/CharSet/Unicode.hs new file mode 100644 --- /dev/null +++ b/Data/CharSet/Unicode.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.CharSet.Unicode +-- Copyright : (c) Edward Kmett 2010 +-- License : BSD3 +-- Maintainer : ekmett@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Provides unicode general categories, which are typically connoted by +-- @\p{Ll}@ or @\p{Modifier_Letter}@. Lookups can be constructed using 'categories' +-- or individual character sets can be used directly. +------------------------------------------------------------------------------- + +module Data.CharSet.Unicode + ( + -- * Unicode General Category + UnicodeCategory(..) + -- * Lookup + , unicodeCategories + -- * CharSets by UnicodeCategory + -- ** Letter + , modifierLetter, otherLetter, letter + -- *** Letter\& + , lowercaseLetter, uppercaseLetter, titlecaseLetter, letterAnd + -- ** Mark + , nonSpacingMark, spacingCombiningMark, enclosingMark, mark + -- ** Separator + , space, lineSeparator, paragraphSeparator, separator + -- ** Symbol + , mathSymbol, currencySymbol, modifierSymbol, otherSymbol, symbol + -- ** Number + , decimalNumber, letterNumber, otherNumber, number + -- ** Punctuation + , dashPunctuation, openPunctuation, closePunctuation, initialQuote + , finalQuote, connectorPunctuation, otherPunctuation, punctuation + -- ** Other + , control, format, privateUse, surrogate, notAssigned, other + ) where + +import Data.Char +import Data.CharSet +import Data.Data + +data UnicodeCategory = UnicodeCategory String String CharSet String + deriving (Show, Data, Typeable) + +-- \p{Letter} or \p{Mc} +unicodeCategories :: [UnicodeCategory] +unicodeCategories = + [ UnicodeCategory "Letter" "L" letter "any kind of letter from any language." + , UnicodeCategory "Lowercase_Letter" "Ll" lowercaseLetter "a lowercase letter that has an uppercase variant" + , UnicodeCategory "Uppercase_Letter" "Lu" uppercaseLetter "an uppercase letter that has a lowercase variant" + , UnicodeCategory "Titlecase_Letter" "Lt" titlecaseLetter "a letter that appears at the start of a word when only the first letter of the word is capitalized" + , UnicodeCategory "Letter&" "L&" letterAnd "a letter that exists in lowercase and uppercase variants (combination of Ll, Lu and Lt)" + , UnicodeCategory "Modifier_Letter" "Lm" modifierLetter "a special character that is used like a letter" + , UnicodeCategory "Other_Letter" "Lo" otherLetter "a letter or ideograph that does not have lowercase and uppercase variants" + , UnicodeCategory "Mark" "M" mark "a character intended to be combined with another character (e.g. accents, umlauts, enclosing boxes, etc.)" + , UnicodeCategory "Non_Spacing_Mark" "Mn" nonSpacingMark "a character intended to be combined with another character without taking up extra space (e.g. accents, umlauts, etc.)" + , UnicodeCategory "Spacing_Combining_Mark" "Mc" spacingCombiningMark "a character intended to be combined with another character that takes up extra space (vowel signs in many Eastern languages)" + , UnicodeCategory "Enclosing_Mark" "Me" enclosingMark "a character that encloses the character is is combined with (circle, square, keycap, etc.)" + , UnicodeCategory "Separator" "Z" separator "any kind of whitespace or invisible separator" + , UnicodeCategory "Space_Separator" "Zs" space "a whitespace character that is invisible, but does take up space" + , UnicodeCategory "Line_Separator" "Zl" lineSeparator "line separator character U+2028" + , UnicodeCategory "Paragraph_Separator" "Zp" paragraphSeparator "paragraph separator character U+2029" + , UnicodeCategory "Symbol" "S" symbol "math symbols, currency signs, dingbats, box-drawing characters, etc." + , UnicodeCategory "Math_Symbol" "Sm" mathSymbol "any mathematical symbol" + , UnicodeCategory "Currency_Symbol" "Sc" currencySymbol "any currency sign" + , UnicodeCategory "Modifier_Symbol" "Sk" modifierSymbol "a combining character (mark) as a full character on its own" + , UnicodeCategory "Other_Symbol" "So" otherSymbol "various symbols that are not math symbols, currency signs, or combining characters" + , UnicodeCategory "Number" "N" number "any kind of numeric character in any script" + , UnicodeCategory "Decimal_Digit_Number" "Nd" decimalNumber "a digit zero through nine in any script except ideographic scripts" + , UnicodeCategory "Letter_Number" "Nl" letterNumber "a number that looks like a letter, such as a Roman numeral" + , UnicodeCategory "Other_Number" "No" otherNumber "a superscript or subscript digit, or a number that is not a digit 0..9 (excluding numbers from ideographic scripts)" + , UnicodeCategory "Punctuation" "P" punctuation "any kind of punctuation character" + , UnicodeCategory "Dash_Punctuation" "Pd" dashPunctuation "any kind of hyphen or dash" + , UnicodeCategory "Open_Punctuation" "Ps" openPunctuation "any kind of opening bracket" + , UnicodeCategory "Close_Punctuation" "Pe" closePunctuation "any kind of closing bracket" + , UnicodeCategory "Initial_Punctuation" "Pi" initialQuote "any kind of opening quote" + , UnicodeCategory "Final_Punctuation" "Pf" finalQuote "any kind of closing quote" + , UnicodeCategory "Connector_Punctuation" "Pc" connectorPunctuation "a punctuation character such as an underscore that connects words" + , UnicodeCategory "Other_Punctuation" "Po" otherPunctuation "any kind of punctuation character that is not a dash, bracket, quote or connector" + , UnicodeCategory "Other" "C" other "invisible control characters and unused code points" + , UnicodeCategory "Control" "Cc" control "an ASCII 0x00..0x1F or Latin-1 0x80..0x9F control character" + , UnicodeCategory "Format" "Cf" format "invisible formatting indicator" + , UnicodeCategory "Private_Use" "Co" privateUse "any code point reserved for private use" + , UnicodeCategory "Surrogate" "Cs" surrogate "one half of a surrogate pair in UTF-16 encoding" + , UnicodeCategory "Unassigned" "Cn" notAssigned "any code point to which no character has been assigned.properties" ] + +cat :: GeneralCategory -> CharSet +cat category = build ((category ==) . generalCategory) + +-- Letter +lowercaseLetter, uppercaseLetter, titlecaseLetter, letterAnd, modifierLetter, otherLetter, letter :: CharSet +lowercaseLetter = cat LowercaseLetter +uppercaseLetter = cat UppercaseLetter +titlecaseLetter = cat TitlecaseLetter +letterAnd = lowercaseLetter + `union` uppercaseLetter + `union` titlecaseLetter +modifierLetter = cat ModifierLetter +otherLetter = cat OtherLetter +letter + = letterAnd + `union` modifierLetter + `union` otherLetter + +-- Marks +nonSpacingMark, spacingCombiningMark, enclosingMark, mark :: CharSet +nonSpacingMark = cat NonSpacingMark +spacingCombiningMark = cat SpacingCombiningMark +enclosingMark = cat EnclosingMark +mark + = nonSpacingMark + `union` spacingCombiningMark + `union` enclosingMark + +space, lineSeparator, paragraphSeparator, separator :: CharSet +space = cat Space +lineSeparator = cat LineSeparator +paragraphSeparator = cat ParagraphSeparator +separator + = space + `union` lineSeparator + `union` paragraphSeparator + +mathSymbol, currencySymbol, modifierSymbol, otherSymbol, symbol :: CharSet +mathSymbol = cat MathSymbol +currencySymbol = cat CurrencySymbol +modifierSymbol = cat ModifierSymbol +otherSymbol = cat OtherSymbol +symbol + = mathSymbol + `union` currencySymbol + `union` modifierSymbol + `union` otherSymbol + +decimalNumber, letterNumber, otherNumber, number :: CharSet +decimalNumber = cat DecimalNumber +letterNumber = cat LetterNumber +otherNumber = cat OtherNumber +number + = decimalNumber + `union` letterNumber + `union` otherNumber + +dashPunctuation, openPunctuation, closePunctuation, initialQuote, + finalQuote, connectorPunctuation, otherPunctuation, punctuation :: CharSet + +dashPunctuation = cat DashPunctuation +openPunctuation = cat OpenPunctuation +closePunctuation = cat ClosePunctuation +initialQuote = cat InitialQuote +finalQuote = cat FinalQuote +connectorPunctuation = cat ConnectorPunctuation +otherPunctuation = cat OtherPunctuation +punctuation + = dashPunctuation + `union` openPunctuation + `union` closePunctuation + `union` initialQuote + `union` finalQuote + `union` connectorPunctuation + `union` otherPunctuation + +control, format, privateUse, surrogate, notAssigned, other :: CharSet +control = cat Control +format = cat Format +privateUse = cat PrivateUse +surrogate = cat Surrogate +notAssigned = cat NotAssigned +other = control + `union` format + `union` privateUse + `union` surrogate + `union` notAssigned diff --git a/charset.cabal b/charset.cabal --- a/charset.cabal +++ b/charset.cabal @@ -1,5 +1,5 @@ name: charset -version: 0.0 +version: 0.1 license: BSD3 license-File: LICENSE copyright: (c) Edward Kmett 2010 @@ -8,8 +8,8 @@ stability: Experimental category: Data homepage: http://github.com/ekmett/charset -synopsis: Fast unicode character sets -description: Fast unicode character sets +synopsis: Fast unicode character sets based on complemented PATRICIA tries +description: Fast unicode character sets based on complemented PATRICIA tries build-type: Simple build-depends: @@ -19,5 +19,8 @@ exposed-modules: Data.CharSet + Data.CharSet.Common + Data.CharSet.Posix.Ascii + Data.CharSet.Unicode GHC-Options: -Wall -fspec-constr -fdicts-cheap -O2