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

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

data CharSet'
type CharSet_ = Ptr CharSet'

withNewCharSet :: (CharSet_ -> IO a) -> IO a
withNewCharSet :: forall a. (CharSet_ -> IO a) -> IO a
withNewCharSet CharSet_ -> IO a
cb = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall a. Ptr a -> Ptr a
throwNull 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 :: forall a. Set Char -> (CharSet_ -> IO a) -> IO a
withCharSet Set Char
chars CharSet_ -> IO a
cb = forall a. (CharSet_ -> IO a) -> IO a
withNewCharSet forall a b. (a -> b) -> a -> b
$ \CharSet_
chars' -> do
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. Set a -> [a]
Set.elems Set Char
chars) forall a b. (a -> b) -> a -> b
$ \Char
ch' ->
        Bool -> IO ()
throwFalse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CharSet_ -> Word32 -> IO Bool
fcCharSetAddChar CharSet_
chars' forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 CharSet_
chars'
    | CharSet_
chars' forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Set a
Set.empty
    | Bool
otherwise = forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
fcCHARSET_MAP_SIZE forall a b. (a -> b) -> a -> b
$ \Ptr Word32
iter' -> forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \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 forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
maxBound then forall (m :: * -> *) a. Monad m => a -> m a
return []
                else do
                    [Word32]
chs <- IO [Word32]
go
                    forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
chforall a. a -> [a] -> [a]
:[Word32]
chs)
        if Word32
first forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
maxBound then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Set a
Set.empty else do
            [Word32]
rest <- IO [Word32]
go
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
unsafeChr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Word32
firstforall a. a -> [a] -> [a]
:[Word32]
rest)
foreign import ccall "my_FcCharSetFirstPage" fcCharSetFirstPage ::
    CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32
foreign import ccall "my_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_ IO CharSet_
cb = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall a. Ptr a -> Ptr a
throwNull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO CharSet_
cb) CharSet_ -> IO ()
fcCharSetDestroy CharSet_ -> IO (Set Char)
thawCharSet