-- NOTE: Untested! module Graphics.Text.Font.Choose.FontSet where import Graphics.Text.Font.Choose.Pattern import Graphics.Text.Font.Choose.Config import Graphics.Text.Font.Choose.ObjectSet import Foreign.Ptr (Ptr, castPtr) import Foreign.Storable (pokeElemOff, sizeOf, peek) import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Marshal.Array (advancePtr) import Control.Monad (forM) import Control.Exception (bracket) type FontSet = [Pattern] fontSetList :: Config -> [FontSet] -> Pattern -> ObjectSet fontSetList config fontss pattern objs = withConfig config $ \config' -> withFontSets fontss $ \fontss' -> withPattern $ \pattern' -> withObjectSet objs $ \objs' -> do ret <- fcFontSetList config' fontss' n pattern' objs' thawFontSet ret foreign import ccall "FcFontSetList" fcFontSetList :: Config_ -> Ptr FontSet_ -> Int -> Pattern_ -> ObjectSet_ -> IO FontSet_ fontSetMatch :: Config -> [FontSet] -> Pattern -> Maybe Pattern fontSetMatch config fontss pattern = withConfig config $ \config' -> withFontSets fontss $ \fontss' -> withPattern $ \pattern' -> alloca $ \res' -> do ret <- fcFontSetMatch config' fontss' n pattern' res' res <- peek res' -- FIXME Is this correct success code? if res == 0 then Just <$> thawPattern ret else return Nothing fontSetSort :: Config -> [FontSet] -> Pattern -> Bool -> CharSet -> Maybe FontSet fontSetSort config fontss pattern trim csp cb = withConfig config $ \config' -> withFontSets fontss $ \fontss' withPattern $ \pattern' -> withCharSet csp $ \csp' -> alloca $ \res' -> do ret' <- fcFontSetSort config' fontss' n pattern' trim csp' res' res <- peek res' ret <- if res == 0 then Just <$> thawFontSet ret' else return Nothing fcFontSetDestroy ret' return ret ------ --- Low-level ------ type FontSet' = Int type FontSet_ = Ptr FontSet' withNewFontSet :: (FontSet_ -> IO a) -> IO a withNewFontSet = bracket fcFontSetCreate fcFontSetDestroy foreign import ccall "FcFontSetCreate" fcFontSetCreate :: IO FontSet_ foreign import ccall "FcFontSetDestroy" fcFontSetDestroy :: FontSet_ -> IO () withFontSet :: FontSet -> (FontSet_ -> IO a) -> IO a withFontSet fonts cb = withNewFontSet $ \fonts' -> forM fonts $ \font -> (fcFontSetAdd fonts' =<< patternAsPointer font) cb fonts' withFontSets :: [FontSet] -> (Ptr FontSet_ -> IO a) -> IO a withFontSets fontss cb = let n = length fontss in allocaBytes (sizeOf (undefined :: FontSet_) * n) $ \fontss' -> withFontSets' fontss 0 fontss' -> cb fontss' withFontSets' :: [FontSet] -> Int -> Ptr FontSet_ -> IO a -> IO a withFontSets' [] _ _ cb = cb withFontSets' (fonts:fontss) i fontss' cb = withFontSet fonts $ \fonts' -> do pokeElemOff fontss' i fonts' withFontSets fontss (succ i) fontss' cb thawFontSet :: FontSet_ -> IO FontSet thawFontSet fonts' = do n <- peek fonts' array <- peek $ castPtr $ advancePtr fonts' 2 if n == 0 || array == nullPtr then return [] else forM [0..pred n] $ \i -> thawPattern (advancePtr array i)