-- | Process sets of unicode characters, possibly parsed from CSS.
module Graphics.Text.Font.Choose.CharSet(
        CharSet, ord, chr, module IntSet, parseCharSet, CharSet'(..), validCharSet'
    ) where

import Data.IntSet as IntSet

import Data.Char (isHexDigit, isSpace, ord, chr)
import Numeric (readHex)

import Data.MessagePack (MessagePack(..), Object(..))
import Test.QuickCheck (Arbitrary(..))

-- | An FcCharSet is a set of Unicode characters.
type CharSet = IntSet

parseChar :: String -> Int
parseChar :: String -> Key
parseChar String
str | ((Key
x, String
_):[(Key, String)]
_) <- ReadS Key
forall a. (Eq a, Num a) => ReadS a
readHex String
str = Key -> Key
forall a. Enum a => Key -> a
toEnum Key
x
    | Bool
otherwise = Key
0
replaceWild :: Char -> String -> String
replaceWild :: Char -> String -> String
replaceWild Char
ch (Char
'?':String
rest) = Char
chChar -> String -> String
forall a. a -> [a] -> [a]
:Char -> String -> String
replaceWild Char
ch String
rest
replaceWild Char
ch (Char
c:String
cs) = Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:Char -> String -> String
replaceWild Char
ch String
cs
replaceWild Char
_ String
"" = String
""
parseWild :: Char -> String -> Int
parseWild :: Char -> String -> Key
parseWild Char
ch String
str = String -> Key
parseChar (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Char -> String -> String
replaceWild Char
ch String
str
-- | Utility for parsing "unicode-range" @font-face property.
parseCharSet :: String -> Maybe CharSet
parseCharSet :: String -> Maybe CharSet
parseCharSet (Char
c:String
rest) | Char -> Bool
isSpace Char
c = String -> Maybe CharSet
parseCharSet String
rest -- Irrelevant in Stylist integration.
parseCharSet (Char
'U':String
rest) = String -> Maybe CharSet
parseCharSet (Char
'u'Char -> String -> String
forall a. a -> [a] -> [a]
:String
rest) -- lowercase initial "u"
parseCharSet (Char
'u':Char
'+':String
cs)
    | (start :: String
start@(Char
_:String
_), Char
'-':String
ends) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isHexDigit String
cs,
        (end :: String
end@(Char
_:String
_), String
rest) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isHexDigit String
ends, Just CharSet
set <- String -> Maybe CharSet
parseCharSet' String
rest =
            CharSet -> Maybe CharSet
forall a. a -> Maybe a
Just (CharSet -> Maybe CharSet) -> CharSet -> Maybe CharSet
forall a b. (a -> b) -> a -> b
$ CharSet -> CharSet -> CharSet
union CharSet
set (CharSet -> CharSet) -> CharSet -> CharSet
forall a b. (a -> b) -> a -> b
$ [Key] -> CharSet
IntSet.fromList [String -> Key
parseChar String
start..String -> Key
parseChar String
end]
    | (codepoint :: String
codepoint@(Char
_:String
_), String
rest) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isHexDigit String
cs, Just CharSet
set <- String -> Maybe CharSet
parseCharSet' String
rest =
        CharSet -> Maybe CharSet
forall a. a -> Maybe a
Just (CharSet -> Maybe CharSet) -> CharSet -> Maybe CharSet
forall a b. (a -> b) -> a -> b
$ (Key -> CharSet -> CharSet) -> CharSet -> Key -> CharSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip Key -> CharSet -> CharSet
IntSet.insert CharSet
set (Key -> CharSet) -> Key -> CharSet
forall a b. (a -> b) -> a -> b
$ String -> Key
parseChar String
codepoint
    | (codepoint :: String
codepoint@(Char
_:String
_), String
rest) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\Char
c -> Char -> Bool
isHexDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'?') String
cs,
        Just CharSet
set <- String -> Maybe CharSet
parseCharSet' String
rest =
            CharSet -> Maybe CharSet
forall a. a -> Maybe a
Just (CharSet -> Maybe CharSet) -> CharSet -> Maybe CharSet
forall a b. (a -> b) -> a -> b
$ CharSet -> CharSet -> CharSet
IntSet.union CharSet
set (CharSet -> CharSet) -> CharSet -> CharSet
forall a b. (a -> b) -> a -> b
$ [Key] -> CharSet
IntSet.fromList [
                Char -> String -> Key
parseWild Char
'0' String
codepoint..Char -> String -> Key
parseWild Char
'f' String
codepoint]
parseCharSet String
_ = Maybe CharSet
forall a. Maybe a
Nothing
parseCharSet' :: String -> Maybe CharSet
parseCharSet' :: String -> Maybe CharSet
parseCharSet' (Char
',':String
rest) = String -> Maybe CharSet
parseCharSet String
rest
parseCharSet' String
"" = CharSet -> Maybe CharSet
forall a. a -> Maybe a
Just CharSet
IntSet.empty
parseCharSet' String
_ = Maybe CharSet
forall a. Maybe a
Nothing

-- NOTE: Serial already provides IntSet a CBOR codec, but its quite naive.
-- I suspect that CharSets are typically quite dense,
-- So a diff-compression pass should play well with 

diffCompress :: Int -> [Int] -> [Int]
diffCompress :: Key -> [Key] -> [Key]
diffCompress Key
prev (Key
x:[Key]
xs) = Key
x Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
prevKey -> [Key] -> [Key]
forall a. a -> [a] -> [a]
:Key -> [Key] -> [Key]
diffCompress Key
x [Key]
xs
diffCompress Key
_ [] = []
diffDecompress :: Int -> [Int] -> [Int]
diffDecompress :: Key -> [Key] -> [Key]
diffDecompress Key
prev (Key
x:[Key]
xs) = let y :: Key
y = Key
prev Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
x in Key
yKey -> [Key] -> [Key]
forall a. a -> [a] -> [a]
:Key -> [Key] -> [Key]
diffDecompress Key
y [Key]
xs
diffDecompress Key
_ [] = []

-- | Wrapper around `CharSet` which can implement typeclasses.
newtype CharSet' = CharSet' { CharSet' -> CharSet
unCharSet :: CharSet } deriving (CharSet' -> CharSet' -> Bool
(CharSet' -> CharSet' -> Bool)
-> (CharSet' -> CharSet' -> Bool) -> Eq CharSet'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CharSet' -> CharSet' -> Bool
== :: CharSet' -> CharSet' -> Bool
$c/= :: CharSet' -> CharSet' -> Bool
/= :: CharSet' -> CharSet' -> Bool
Eq, ReadPrec [CharSet']
ReadPrec CharSet'
Key -> ReadS CharSet'
ReadS [CharSet']
(Key -> ReadS CharSet')
-> ReadS [CharSet']
-> ReadPrec CharSet'
-> ReadPrec [CharSet']
-> Read CharSet'
forall a.
(Key -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Key -> ReadS CharSet'
readsPrec :: Key -> ReadS CharSet'
$creadList :: ReadS [CharSet']
readList :: ReadS [CharSet']
$creadPrec :: ReadPrec CharSet'
readPrec :: ReadPrec CharSet'
$creadListPrec :: ReadPrec [CharSet']
readListPrec :: ReadPrec [CharSet']
Read, Key -> CharSet' -> String -> String
[CharSet'] -> String -> String
CharSet' -> String
(Key -> CharSet' -> String -> String)
-> (CharSet' -> String)
-> ([CharSet'] -> String -> String)
-> Show CharSet'
forall a.
(Key -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Key -> CharSet' -> String -> String
showsPrec :: Key -> CharSet' -> String -> String
$cshow :: CharSet' -> String
show :: CharSet' -> String
$cshowList :: [CharSet'] -> String -> String
showList :: [CharSet'] -> String -> String
Show)
instance MessagePack CharSet' where
    toObject :: CharSet' -> Object
toObject = [Key] -> Object
forall a. MessagePack a => a -> Object
toObject ([Key] -> Object) -> (CharSet' -> [Key]) -> CharSet' -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> [Key] -> [Key]
diffCompress Key
0 ([Key] -> [Key]) -> (CharSet' -> [Key]) -> CharSet' -> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharSet -> [Key]
IntSet.toAscList (CharSet -> [Key]) -> (CharSet' -> CharSet) -> CharSet' -> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharSet' -> CharSet
unCharSet
    fromObject :: Object -> Maybe CharSet'
fromObject (ObjectExt Word8
0x63 ByteString
_) = CharSet' -> Maybe CharSet'
forall a. a -> Maybe a
Just (CharSet' -> Maybe CharSet') -> CharSet' -> Maybe CharSet'
forall a b. (a -> b) -> a -> b
$ CharSet -> CharSet'
CharSet' CharSet
IntSet.empty
    fromObject Object
msg =
        CharSet -> CharSet'
CharSet' (CharSet -> CharSet') -> ([Key] -> CharSet) -> [Key] -> CharSet'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Key] -> CharSet
IntSet.fromAscList ([Key] -> CharSet') -> ([Key] -> [Key]) -> [Key] -> CharSet'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> [Key] -> [Key]
diffDecompress Key
0 ([Key] -> CharSet') -> Maybe [Key] -> Maybe CharSet'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Maybe [Key]
forall a. MessagePack a => Object -> Maybe a
fromObject Object
msg
instance Arbitrary CharSet' where
    arbitrary :: Gen CharSet'
arbitrary = CharSet -> CharSet'
CharSet' (CharSet -> CharSet') -> ([Key] -> CharSet) -> [Key] -> CharSet'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Key] -> CharSet
IntSet.fromList ([Key] -> CharSet') -> ([Key] -> [Key]) -> [Key] -> CharSet'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Key -> Key) -> [Key] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map (Key -> Key
forall a. Enum a => a -> a
succ (Key -> Key) -> (Key -> Key) -> Key -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Key
forall a. Num a => a -> a
abs) ([Key] -> CharSet') -> Gen [Key] -> Gen CharSet'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [Key]
forall a. Arbitrary a => Gen a
arbitrary

-- | Can this charset be processed by FontConfig?
validCharSet' :: CharSet' -> Bool
validCharSet' :: CharSet' -> Bool
validCharSet' (CharSet' CharSet
self) =
    Bool -> Bool
not (CharSet -> Bool
IntSet.null CharSet
self) Bool -> Bool -> Bool
&& (Key -> Bool) -> [Key] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
0) (CharSet -> [Key]
IntSet.toList CharSet
self)