module Graphics.Text.Font.Choose.CharSet where

import Data.Set (Set, union)
import qualified Data.Set as Set
import Graphics.Text.Font.Choose.Result (throwNull, throwFalse)

import Data.Word (Word32)
import Foreign.Ptr
import Control.Exception (bracket)
import Control.Monad (forM)
import Foreign.Marshal.Alloc (alloca, allocaBytes)
import GHC.Base (unsafeChr)
import Data.Char (ord, isHexDigit)
import Numeric (readHex)

-- | An FcCharSet is a set of Unicode chars.
type CharSet = Set Char

parseChar :: String -> Char
parseChar :: String -> Char
parseChar str :: String
str | ((x :: Int
x, _):_) <- ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex String
str = Int -> Char
forall a. Enum a => Int -> a
toEnum Int
x
replaceWild :: Char -> String -> String
replaceWild ch :: Char
ch ('?':rest :: String
rest) = Char
chChar -> String -> String
forall a. a -> [a] -> [a]
:Char -> String -> String
replaceWild Char
ch String
rest
replaceWild ch :: Char
ch (c :: Char
c:cs :: String
cs) = Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:Char -> String -> String
replaceWild Char
ch String
cs
replaceWild _ "" = ""
parseWild :: Char -> String -> Char
parseWild ch :: Char
ch str :: String
str = String -> Char
parseChar (String -> Char) -> String -> Char
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 (Set Char)
parseCharSet ('U':rest :: String
rest) = String -> Maybe (Set Char)
parseCharSet ('u'Char -> String -> String
forall a. a -> [a] -> [a]
:String
rest) -- lowercase initial "u"
parseCharSet ('u':'+':cs :: String
cs)
    | (start :: String
start@(_:_), '-':ends :: String
ends) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isHexDigit String
cs,
        (end :: String
end@(_:_), rest :: String
rest) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isHexDigit String
ends, Just set :: Set Char
set <- String -> Maybe (Set Char)
parseCharSet' String
rest =
            Set Char -> Maybe (Set Char)
forall a. a -> Maybe a
Just (Set Char -> Maybe (Set Char)) -> Set Char -> Maybe (Set Char)
forall a b. (a -> b) -> a -> b
$ Set Char -> Set Char -> Set Char
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Char
set (Set Char -> Set Char) -> Set Char -> Set Char
forall a b. (a -> b) -> a -> b
$ String -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList [String -> Char
parseChar String
start..String -> Char
parseChar String
end]
    | (codepoint :: String
codepoint@(_:_), rest :: String
rest) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isHexDigit String
cs, Just set :: Set Char
set <- String -> Maybe (Set Char)
parseCharSet' String
rest =
        Set Char -> Maybe (Set Char)
forall a. a -> Maybe a
Just (Set Char -> Maybe (Set Char)) -> Set Char -> Maybe (Set Char)
forall a b. (a -> b) -> a -> b
$ (Char -> Set Char -> Set Char) -> Set Char -> Char -> Set Char
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> Set Char -> Set Char
forall a. Ord a => a -> Set a -> Set a
Set.insert Set Char
set (Char -> Set Char) -> Char -> Set Char
forall a b. (a -> b) -> a -> b
$ String -> Char
parseChar String
codepoint
    | (codepoint :: String
codepoint@(_:_), rest :: String
rest) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\c :: Char
c -> Char -> Bool
isHexDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '?') String
cs,
        Just set :: Set Char
set <- String -> Maybe (Set Char)
parseCharSet' String
rest =
            Set Char -> Maybe (Set Char)
forall a. a -> Maybe a
Just (Set Char -> Maybe (Set Char)) -> Set Char -> Maybe (Set Char)
forall a b. (a -> b) -> a -> b
$ Set Char -> Set Char -> Set Char
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Char
set (Set Char -> Set Char) -> Set Char -> Set Char
forall a b. (a -> b) -> a -> b
$ String -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList [
                Char -> String -> Char
parseWild '0' String
codepoint..Char -> String -> Char
parseWild 'f' String
codepoint]
parseCharSet _ = Maybe (Set Char)
forall a. Maybe a
Nothing
parseCharSet' :: String -> Maybe (Set Char)
parseCharSet' (',':rest :: String
rest) = String -> Maybe (Set Char)
parseCharSet String
rest
parseCharSet' "" = Set Char -> Maybe (Set Char)
forall a. a -> Maybe a
Just Set Char
forall a. Set a
Set.empty
parseCharSet' _ = Maybe (Set Char)
forall a. Maybe a
Nothing

------
--- Low-level
------

data CharSet'
type CharSet_ = Ptr CharSet'

withNewCharSet :: (CharSet_ -> IO a) -> IO a
withNewCharSet :: (CharSet_ -> IO a) -> IO a
withNewCharSet cb :: CharSet_ -> IO a
cb = IO CharSet_ -> (CharSet_ -> IO ()) -> (CharSet_ -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (CharSet_ -> CharSet_
forall a. Ptr a -> Ptr a
throwNull (CharSet_ -> CharSet_) -> IO CharSet_ -> IO CharSet_
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO CharSet_
fcCharSetCreate) CharSet_ -> IO ()
fcCharSetDestroy CharSet_ -> IO a
cb
foreign import ccall "FcCharSetCreate" fcCharSetCreate :: IO CharSet_
foreign import ccall "FcCharSetDestroy" fcCharSetDestroy :: CharSet_ -> IO ()

withCharSet :: CharSet -> (CharSet_ -> IO a) -> IO a
withCharSet :: Set Char -> (CharSet_ -> IO a) -> IO a
withCharSet chars :: Set Char
chars cb :: CharSet_ -> IO a
cb = (CharSet_ -> IO a) -> IO a
forall a. (CharSet_ -> IO a) -> IO a
withNewCharSet ((CharSet_ -> IO a) -> IO a) -> (CharSet_ -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \chars' :: CharSet_
chars' -> do
    String -> (Char -> IO (IO ())) -> IO [IO ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Set Char -> String
forall a. Set a -> [a]
Set.elems Set Char
chars) ((Char -> IO (IO ())) -> IO [IO ()])
-> (Char -> IO (IO ())) -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ \ch' :: Char
ch' ->
        Bool -> IO ()
throwFalse (Bool -> IO ()) -> IO Bool -> IO (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CharSet_ -> Word32 -> IO Bool
fcCharSetAddChar CharSet_
chars' (Word32 -> IO Bool) -> Word32 -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
ch')
    CharSet_ -> IO a
cb CharSet_
chars'
foreign import ccall "FcCharSetAddChar" fcCharSetAddChar :: CharSet_ -> Word32 -> IO Bool

thawCharSet :: CharSet_ -> IO CharSet
thawCharSet :: CharSet_ -> IO (Set Char)
thawCharSet chars' :: CharSet_
chars'
    | CharSet_
chars' CharSet_ -> CharSet_ -> Bool
forall a. Eq a => a -> a -> Bool
== CharSet_
forall a. Ptr a
nullPtr = Set Char -> IO (Set Char)
forall (m :: * -> *) a. Monad m => a -> m a
return Set Char
forall a. Set a
Set.empty
    | Bool
otherwise = Int -> (Ptr Word32 -> IO (Set Char)) -> IO (Set Char)
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
fcCHARSET_MAP_SIZE ((Ptr Word32 -> IO (Set Char)) -> IO (Set Char))
-> (Ptr Word32 -> IO (Set Char)) -> IO (Set Char)
forall a b. (a -> b) -> a -> b
$ \iter' :: Ptr Word32
iter' -> (Ptr Word32 -> IO (Set Char)) -> IO (Set Char)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Word32 -> IO (Set Char)) -> IO (Set Char))
-> (Ptr Word32 -> IO (Set Char)) -> IO (Set Char)
forall a b. (a -> b) -> a -> b
$ \next' :: Ptr Word32
next' -> do
        Word32
first <- CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32
fcCharSetFirstPage CharSet_
chars' Ptr Word32
iter' Ptr Word32
next'
        let go :: IO [Word32]
go = do
                Word32
ch <- CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32
fcCharSetNextPage CharSet_
chars' Ptr Word32
iter' Ptr Word32
next';
                if Word32
ch Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
forall a. Bounded a => a
maxBound then [Word32] -> IO [Word32]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                else do
                    [Word32]
chs <- IO [Word32]
go
                    [Word32] -> IO [Word32]
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
chWord32 -> [Word32] -> [Word32]
forall a. a -> [a] -> [a]
:[Word32]
chs)
        if Word32
first Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
forall a. Bounded a => a
maxBound then Set Char -> IO (Set Char)
forall (m :: * -> *) a. Monad m => a -> m a
return Set Char
forall a. Set a
Set.empty else do
            [Word32]
rest <- IO [Word32]
go
            Set Char -> IO (Set Char)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Char -> IO (Set Char)) -> Set Char -> IO (Set Char)
forall a b. (a -> b) -> a -> b
$ String -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList (String -> Set Char) -> String -> Set Char
forall a b. (a -> b) -> a -> b
$ (Word32 -> Char) -> [Word32] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
unsafeChr (Int -> Char) -> (Word32 -> Int) -> Word32 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Word32
firstWord32 -> [Word32] -> [Word32]
forall a. a -> [a] -> [a]
:[Word32]
rest)
foreign import ccall "FcCharSetFirstPage" fcCharSetFirstPage ::
    CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32
foreign import ccall "FcCharSetNextPage" fcCharSetNextPage ::
    CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32
foreign import ccall "my_FcCHARSET_MAP_SIZE" fcCHARSET_MAP_SIZE :: Int

thawCharSet_ :: IO CharSet_ -> IO CharSet
thawCharSet_ :: IO CharSet_ -> IO (Set Char)
thawCharSet_ cb :: IO CharSet_
cb = IO CharSet_
-> (CharSet_ -> IO ())
-> (CharSet_ -> IO (Set Char))
-> IO (Set Char)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (CharSet_ -> CharSet_
forall a. Ptr a -> Ptr a
throwNull (CharSet_ -> CharSet_) -> IO CharSet_ -> IO CharSet_
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO CharSet_
cb) CharSet_ -> IO ()
fcCharSetDestroy CharSet_ -> IO (Set Char)
thawCharSet