module Graphics.Text.Font.Choose.CharSet where

import Data.IntSet (IntSet, union)
import qualified Data.IntSet as IntSet
import Graphics.Text.Font.Choose.Result (throwNull, throwFalse)
import System.IO.Unsafe (unsafeInterleaveIO)

import Data.Word (Word32)
import Foreign.Ptr
import Foreign.ForeignPtr (newForeignPtr, withForeignPtr)
import Control.Exception (bracket)
import Foreign.Storable (peek)
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 = IntSet

parseChar :: String -> Int
parseChar :: String -> Key
parseChar String
str | ((Key
x, String
_):[(Key, String)]
_) <- forall a. (Eq a, Num a) => ReadS a
readHex String
str = forall a. Enum a => Key -> a
toEnum Key
x
replaceWild :: Char -> String -> String
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 -> Int
parseWild :: Char -> String -> Key
parseWild Char
ch String
str = String -> Key
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 CharSet
parseCharSet :: String -> Maybe CharSet
parseCharSet (Char
'U':String
rest) = String -> Maybe CharSet
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 CharSet
set <- String -> Maybe CharSet
parseCharSet' String
rest =
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ CharSet -> CharSet -> CharSet
union CharSet
set 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) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isHexDigit String
cs, Just CharSet
set <- String -> Maybe CharSet
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 Key -> CharSet -> CharSet
IntSet.insert CharSet
set forall a b. (a -> b) -> a -> b
$ String -> Key
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 CharSet
set <- String -> Maybe CharSet
parseCharSet' String
rest =
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ CharSet -> CharSet -> CharSet
IntSet.union CharSet
set 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
_ = 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
"" = forall a. a -> Maybe a
Just CharSet
IntSet.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. CharSet -> (CharSet_ -> IO a) -> IO a
withCharSet CharSet
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 (CharSet -> [Key]
IntSet.elems CharSet
chars) forall a b. (a -> b) -> a -> b
$ \Key
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 Key
ch')
    CharSet_ -> IO a
cb CharSet_
chars'
foreign import ccall "FcCharSetAddChar" fcCharSetAddChar :: CharSet_ -> Word32 -> IO Bool

thawCharSet :: CharSet_ -> IO CharSet
thawCharSet :: CharSet_ -> IO CharSet
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 CharSet
IntSet.empty
    | Bool
otherwise = do
        Ptr CharSetIter'
iter' <- forall a. Ptr a -> Ptr a
throwNull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CharSet_ -> IO (Ptr CharSetIter')
fcCharSetIterCreate CharSet_
chars'
        ForeignPtr CharSetIter'
iter <- forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr (FunPtr (Ptr CharSetIter' -> IO ())
fcCharSetIterDestroy) Ptr CharSetIter'
iter'
        Word32
x <- forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CharSetIter'
iter Ptr CharSetIter' -> IO Word32
fcCharSetIterStart
        let go :: Word32 -> IO [Word32]
go Word32
x' | Word32 -> Bool
fcCharSetIterDone Word32
x' = forall (m :: * -> *) a. Monad m => a -> m a
return []
                | Bool
otherwise = forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ do
                    Word32
y <- forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CharSetIter'
iter Ptr CharSetIter' -> IO Word32
fcCharSetIterNext
                    [Word32]
xs <- Word32 -> IO [Word32]
go Word32
y
                    forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
x'forall a. a -> [a] -> [a]
:[Word32]
xs)
        [Word32]
ret <- Word32 -> IO [Word32]
go Word32
x
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Key] -> CharSet
IntSet.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Word32]
ret
data CharSetIter'
type CharSetIter_ = Ptr CharSetIter'
foreign import ccall "my_FcCharSetIterCreate" fcCharSetIterCreate ::
    CharSet_ -> IO CharSetIter_
foreign import ccall "&my_FcCharSetIterDestroy" fcCharSetIterDestroy ::
    FunPtr (CharSetIter_ -> IO ())
foreign import ccall "my_FcCharSetIterStart" fcCharSetIterStart ::
    CharSetIter_ -> IO Word32
foreign import ccall "my_FcCharSetIterNext" fcCharSetIterNext ::
    CharSetIter_ -> IO Word32
foreign import ccall "my_FcCharSetIterDone" fcCharSetIterDone :: Word32 -> Bool

thawCharSet_ :: IO CharSet_ -> IO CharSet
thawCharSet_ :: IO CharSet_ -> IO CharSet
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 CharSet
thawCharSet
thawCharSet' :: Ptr CharSet_ -> IO CharSet
thawCharSet' :: Ptr CharSet_ -> IO CharSet
thawCharSet' = IO CharSet_ -> IO CharSet
thawCharSet_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => Ptr a -> IO a
peek