module Graphics.Text.Font.Choose.CharSet where

import Data.Set (Set)
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)

type CharSet = Set Char

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

data CharSet'
type CharSet_ = Ptr CharSet'

withNewCharSet :: (CharSet_ -> IO a) -> IO a
withNewCharSet cb = bracket (throwNull <$> fcCharSetCreate) fcCharSetDestroy cb
foreign import ccall "FcCharSetCreate" fcCharSetCreate :: IO CharSet_
foreign import ccall "FcCharSetDestroy" fcCharSetDestroy :: CharSet_ -> IO ()

withCharSet :: CharSet -> (CharSet_ -> IO a) -> IO a
withCharSet chars cb = withNewCharSet $ \chars' -> do
    forM (Set.elems chars) $ \ch' ->
        throwFalse <$> (fcCharSetAddChar chars' $ fromIntegral $ ord ch')
    cb chars'
foreign import ccall "FcCharSetAddChar" fcCharSetAddChar :: CharSet_ -> Word32 -> IO Bool

thawCharSet :: CharSet_ -> IO CharSet
thawCharSet chars' = allocaBytes fcCHARSET_MAP_SIZE $ \iter' -> alloca $ \next' -> do
    first <- fcCharSetFirstPage chars' iter' next'
    let go = do {
        ch <- fcCharSetNextPage chars' iter' next';
        if ch == maxBound then return []
        else do
            chs <- go
            return (ch:chs)
      }
    if first == maxBound then return Set.empty else do
        rest <- go
        return $ Set.fromList $ map (unsafeChr . fromIntegral) (first: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_ cb = bracket (throwNull <$> cb) fcCharSetDestroy thawCharSet