Font.hs

{-# LANGUAGE PackageImports #-}
module Data.Text.Glyphize.Font where

import Data.ByteString
import FreeType.Core.Base
import Data.Text.Glyphize.Buffer (Direction(..), dir2int, hb_tag_to_string)

import System.IO.Unsafe (unsafePerformIO)
import Foreign.Ptr
import Foreign.StablePtr
import Foreign.ForeignPtr
import qualified Foreign.Concurrent as Conc
import Foreign.Marshal.Alloc
import Foreign.Storable
import Foreign.C.String

import Data.Maybe (fromMaybe)
import Data.Word
import Data.Int
import Data.ByteString.Internal hiding (c2w)
import Codec.Binary.UTF8.Light (c2w)
import Control.Monad (forM)

type Face = ForeignPtr Face'
type Face_ = Ptr Face'
data Face'

foreign import ccall "hb_face_count" hb_face_count :: Blob_ -> IO Word
countFace :: ByteString -> Word
countFace bytes = unsafePerformIO $ do
    blob <- bs2blob bytes
    withForeignPtr blob hb_face_count

foreign import ccall "hb_face_create" hb_face_create :: Blob_ -> Word -> IO Face_
foreign import ccall "hb_face_destroy" hb_face_destroy :: Face_ -> IO ()
foreign import ccall "&hb_face_destroy" hb_face_destroy' :: FunPtr (Face_ -> IO ())
createFace :: ByteString -> Word -> Face
createFace bytes index = unsafePerformIO $ do
    blob <- bs2blob bytes
    face <- withForeignPtr blob $ flip hb_face_create index
    Conc.newForeignPtr face $ hb_face_destroy face

foreign import ccall "hb_ft_face_create_referenced" hb_ft_face_create_referenced
    :: FT_Face -> Face_
ftCreateFace :: FT_Face -> Face
ftCreateFace =
    unsafePerformIO . newForeignPtr hb_face_destroy' . hb_ft_face_create_referenced

foreign import ccall "hb_face_get_empty" hb_face_get_empty :: Face_
emptyFace :: Face
emptyFace = unsafePerformIO $ newForeignPtr hb_face_destroy' hb_face_get_empty

foreign import ccall "hb_face_get_table_tags" hb_face_get_table_tags
    :: Face_ -> Word -> Ptr Word -> Ptr Word32 -> IO Word
faceTableTags :: Face -> Word -> Word -> (Word, [String])
faceTableTags fce offs cnt = unsafePerformIO $ withForeignPtr fce $ \fce' -> do
    alloca $ \cnt' -> allocaBytes (fromEnum cnt * 4) $ \arr' -> do
        poke cnt' cnt
        length <- hb_face_get_table_tags fce' offs cnt' arr'
        cnt_ <- peek cnt'
        arr <- forM [0..fromEnum cnt_-1] $ peekElemOff arr'
        return (length, Prelude.map hb_tag_to_string arr)

foreign import ccall "hb_face_get_glyph_count" hb_face_get_glyph_count :: Face_ -> Word
faceGlyphCount :: Face -> Word
faceGlyphCount = faceFunc hb_face_get_glyph_count

foreign import ccall "hb_face_collect_unicodes" hb_face_collect_unicodes
    :: Face_ -> Set_ -> IO ()
faceCollectUnicodes :: Face -> [Word32]
faceCollectUnicodes = faceCollectFunc hb_face_collect_unicodes

foreign import ccall "hb_face_collect_variation_selectors"
    hb_face_collect_variation_selectors :: Face_ -> Set_ -> IO ()
faceCollectVarSels :: Face -> [Word32]
faceCollectVarSels = faceCollectFunc hb_face_collect_variation_selectors

foreign import ccall "hb_face_collect_variation_unicodes"
    hb_face_collect_variation_unicodes :: Face_ -> Word32 -> Set_ -> IO ()
faceCollectVarUnicodes :: Face -> Word32 -> [Word32]
faceCollectVarUnicodes fce varSel = unsafePerformIO $ withForeignPtr fce $ \fce' -> do
    set <- createSet
    withForeignPtr set $ hb_face_collect_variation_unicodes fce' varSel
    set2list set

foreign import ccall "hb_face_get_index" hb_face_get_index :: Face_ -> Word
faceIndex :: Face -> Word
faceIndex = faceFunc hb_face_get_index

foreign import ccall "hb_face_get_upem" hb_face_get_upem :: Face_ -> Word
-- | units-per-em
faceUpem :: Face -> Word
faceUpem = faceFunc hb_face_get_upem


-- Defer implementation of other functions...

---

type Font = ForeignPtr Font'
type Font_ = Ptr Font'
data Font'

foreign import ccall "hb_font_create" hb_font_create :: Face_ -> IO Font_
foreign import ccall "hb_font_make_immutable" hb_font_make_immutable :: Font_ -> IO ()
foreign import ccall "hb_font_destroy" hb_font_destroy :: Font_ -> IO ()
foreign import ccall "&hb_font_destroy" hb_font_destroy' :: FunPtr (Font_ -> IO ())
createFont :: Face -> Font
createFont fce = unsafePerformIO $ do
    font <- withForeignPtr fce $ hb_font_create
    hb_font_make_immutable font
    Conc.newForeignPtr font $ hb_font_destroy font

foreign import ccall "hb_ft_font_create_referenced" hb_ft_font_create_referenced
    :: FT_Face -> IO Font_
ftCreateFont :: FT_Face -> IO Font
ftCreateFont fce = do
    font <- hb_ft_font_create_referenced fce
    hb_font_make_immutable font
    newForeignPtr hb_font_destroy' font

foreign import ccall "hb_font_get_empty" hb_font_get_empty :: Font_
emptyFont :: Font
emptyFont = unsafePerformIO $ newForeignPtr hb_font_destroy' hb_font_get_empty

foreign import ccall "hb_font_get_glyph" hb_font_get_glyph
    :: Font_ -> Word32 -> Word32 -> Ptr Word32 -> IO Bool
fontGlyph :: Font -> Char -> Maybe Char -> Maybe Word32
fontGlyph font char var =
    unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do
        success <- hb_font_get_glyph font' (c2w char) (c2w $ fromMaybe '\0' var) ret
        if success then return . Just =<< peek ret else return Nothing

foreign import ccall "hb_font_get_glyph_advance_for_direction"
    hb_font_get_glyph_advance_for_direction
        :: Font_ -> Word32 -> Int -> Ptr Int32 -> Ptr Int32 -> IO ()
fontGlyphAdvance :: Font -> Word32 -> Maybe Direction -> (Int32, Int32)
fontGlyphAdvance font glyph dir = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
        hb_font_get_glyph_advance_for_direction font' glyph (dir2int dir) x' y'
        x <- peek x'
        y <- peek y'
        return (x, y)

foreign import ccall "hb_font_get_glyph_contour_point" hb_font_get_glyph_contour_point
    :: Font_ -> Word32 -> Int -> Ptr Int32 -> Ptr Int32 -> IO Bool
fontGlyphContourPoint :: Font -> Word32 -> Int -> Maybe (Int32, Int32)
fontGlyphContourPoint font glyph index = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
        success <- hb_font_get_glyph_contour_point font' glyph index x' y'
        if success
        then do
            x <- peek x'
            y <- peek y'
            return $ Just (x, y)
        else return Nothing

foreign import ccall "hb_font_get_glyph_contour_point_for_origin"
    hb_font_get_glyph_contour_point_for_origin
        :: Font_ -> Word32 -> Int -> Int -> Ptr Int32 -> Ptr Int32 -> IO Bool
fontGlyphContourPointForOrigin :: Font -> Word32 -> Int -> Maybe Direction -> Maybe (Int32, Int32)
fontGlyphContourPointForOrigin font glyph index dir = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
        success <- hb_font_get_glyph_contour_point_for_origin font' glyph index
                (dir2int dir) x' y'
        if success
        then do
            x <- peek x'
            y <- peek y'
            return $ Just (x, y)
        else return Nothing

data GlyphExtents = GlyphExtents {
    xBearing :: Word32, yBearing :: Word32,
    width :: Word32, height :: Word32
}
instance Storable GlyphExtents where
    sizeOf _ = 4 * sizeOf (undefined :: Word32)
    alignment _ = alignment (undefined :: Word32)
    peek p = do
        q <- return $ castPtr p
        x <- peek q
        y <- peekElemOff q 1
        width <- peekElemOff q 2
        height <- peekElemOff q 3
        return $ GlyphExtents x y width height
    poke p (GlyphExtents x y width height) = do
        q <- return $ castPtr p
        poke q x
        pokeElemOff q 1 y
        pokeElemOff q 2 width
        pokeElemOff q 3 height

foreign import ccall "hb_font_get_glyph_extents" hb_font_get_glyph_extents
    :: Font_ -> Word32 -> Ptr GlyphExtents -> IO Bool
fontGlyphExtents :: Font -> Word32 -> Maybe GlyphExtents
fontGlyphExtents font glyph = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \ret -> do
        success <- hb_font_get_glyph_extents font' glyph ret
        if success
        then return . Just =<< peek ret
        else return Nothing

foreign import ccall "hb_font_get_glyph_extents_for_origin"
    hb_font_get_glyph_extents_for_origin
        :: Font_ -> Word32 -> Int -> Ptr GlyphExtents -> IO Bool
fontGlyphExtentsForOrigin :: Font -> Word32 -> Maybe Direction -> Maybe GlyphExtents
fontGlyphExtentsForOrigin font glyph dir = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \ret -> do
        ok <- hb_font_get_glyph_extents_for_origin font' glyph (dir2int dir) ret
        if ok
        then return . Just =<< peek ret
        else return Nothing

foreign import ccall "hb_font_get_glyph_from_name" hb_font_get_glyph_from_name
    :: Font_ -> CString -> Int -> Ptr Word32 -> IO Bool
fontGlyphFromName :: Font -> String -> Maybe Word32
fontGlyphFromName font name = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \ret -> do
        success <- withCString name $ \name' ->
            hb_font_get_glyph_from_name font' name' (-1) ret
        if success
        then return . Just =<< peek ret
        else return Nothing

foreign import ccall "hb_font_get_glyph_h_advance" hb_font_get_glyph_h_advance
    :: Font_ -> Word32 -> Int32
fontGlyphHAdvance :: Font -> Word32 -> Int32
fontGlyphHAdvance = fontFunc hb_font_get_glyph_h_advance

foreign import ccall "hb_font_get_glyph_h_kerning" hb_font_get_glyph_h_kerning
    :: Font_ -> Word32 -> Word32 -> Int32
fontGlyphHKerning :: Font -> Word32 -> Word32 -> Int32
fontGlyphHKerning = fontFunc hb_font_get_glyph_h_kerning

foreign import ccall "hb_font_get_glyph_h_origin" hb_font_get_glyph_h_origin
    :: Font_ -> Word32 -> Ptr Int32 -> Ptr Int32 -> IO Bool
fontGlyphHOrigin :: Font -> Word32 -> Maybe (Int32, Int32)
fontGlyphHOrigin font glyph = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
        success <- hb_font_get_glyph_h_origin font' glyph x' y'
        if success
        then do
            x <- peek x'
            y <- peek y'
            return $ Just (x, y)
        else return Nothing

foreign import ccall "hb_font_get_glyph_kerning_for_direction"
    hb_font_get_glyph_kerning_for_direction
        :: Font_ -> Word32 -> Word32 -> Int -> Ptr Int32 -> Ptr Int32 -> IO ()
fontGlyphKerningForDir :: Font -> Word32 -> Word32 -> Maybe Direction -> (Int32, Int32)
fontGlyphKerningForDir font glyph1 glyph2 dir = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
        hb_font_get_glyph_kerning_for_direction font' glyph1 glyph2 (dir2int dir) x' y'
        x <- peek x'
        y <- peek y'
        return (x, y)

foreign import ccall "hb_font_get_glyph_name" hb_font_get_glyph_name
    :: Font_ -> Word32 -> CString -> Word -> IO Bool
fontGlyphName :: Font -> Word32 -> Word -> Maybe String
fontGlyphName font glyph length = let lengthi = fromEnum length in unsafePerformIO $
    withForeignPtr font $ \font' -> allocaBytes lengthi $ \ret -> do
        success <- hb_font_get_glyph_name font' glyph ret length
        if success
        then return . Just =<< peekCString ret
        else return Nothing

foreign import ccall "hb_font_get_glyph_origin_for_direction"
    hb_font_get_glyph_origin_for_direction
        :: Font_ -> Word32 -> Int -> Ptr Int32 -> Ptr Int32 -> IO ()
fontGlyphOriginForDir :: Font -> Word32 -> Maybe Direction -> (Int32, Int32)
fontGlyphOriginForDir font glyph dir = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
        hb_font_get_glyph_origin_for_direction font' glyph (dir2int dir) x' y'
        x <- peek x'
        y <- peek y'
        return (x, y)

foreign import ccall "hb_font_get_glyph_v_advance"
    hb_font_get_glyph_v_advance :: Font_ -> Word32 -> Int32
fontGlyphVAdvance :: Font -> Word32 -> Int32
fontGlyphVAdvance = fontFunc hb_font_get_glyph_v_advance

foreign import ccall "hb_font_get_glyph_v_origin" hb_font_get_glyph_v_origin
    :: Font_ -> Word32 -> Ptr Int32 -> Ptr Int32 -> IO Bool
fontGlyphVOrigin :: Font -> Word32 -> Maybe (Int32, Int32)
fontGlyphVOrigin font glyph = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
        success <- hb_font_get_glyph_v_origin font' glyph x' y'
        if success
        then do
            x <- peek x'
            y <- peek y'
            return $ Just (x, y)
        else return Nothing

foreign import ccall "hb_font_get_nominal_glyph" hb_font_get_nominal_glyph
    :: Font_ -> Char -> Ptr Word32 -> IO Bool
fontNominalGlyph :: Font -> Char -> Maybe Word32
fontNominalGlyph font char = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \ret -> do
        success <- hb_font_get_nominal_glyph font' char ret
        if success
        then return . Just =<< peek ret
        else return Nothing

foreign import ccall "hb_font_get_ppem" hb_font_get_ppem
    :: Font_ -> Ptr Word -> Ptr Word -> IO ()
fontPPEm :: Font -> (Word, Word)
fontPPEm font = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
        hb_font_get_ppem font' x' y'
        x_ppem <- peek x'
        y_ppem <- peek y'
        return (x_ppem, y_ppem)

foreign import ccall "hb_font_get_ptem" hb_font_get_ptem :: Font_ -> Float
fontPtEm :: Font -> Float
fontPtEm = fontFunc hb_font_get_ptem

foreign import ccall "hb_font_get_scale" hb_font_get_scale
    :: Font_ -> Ptr Int -> Ptr Int -> IO ()
fontScale :: Font -> (Int, Int)
fontScale font = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
        hb_font_get_scale font' x' y'
        x <- peek x'
        y <- peek y'
        return (x, y)

foreign import ccall "hb_font_get_variation_glyph" hb_font_get_variation_glyph
    :: Font_ -> Word32 -> Word32 -> Ptr Word32 -> IO Bool
fontVarGlyph :: Font -> Word32 -> Word32 -> Maybe Word32
fontVarGlyph font unicode varSel = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \glyph' -> do
        success <- hb_font_get_variation_glyph font' unicode varSel glyph'
        if success
        then return . Just =<< peek glyph'
        else return Nothing

foreign import ccall "hb_font_get_var_coords_normalized"
    hb_font_get_var_coords_normalized :: Font_ -> Ptr Word -> IO (Ptr Int)
fontVarCoordsNormalized :: Font -> [Int]
fontVarCoordsNormalized font = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \length' -> do
        arr <- hb_font_get_var_coords_normalized font' length'
        length <- peek length'
        forM [0..fromEnum length-1] $ peekElemOff arr

foreign import ccall "hb_font_glyph_from_string" hb_font_glyph_from_string
    :: Font_ -> CString -> Int -> Ptr Word32 -> IO Bool
fontTxt2Glyph :: Font -> String -> Maybe Word32
fontTxt2Glyph font str = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \ret -> do
        ok <- withCString str $ \str' ->
            hb_font_glyph_from_string font' str' (-1) ret
        if ok
        then return . Just =<< peek ret
        else return Nothing

foreign import ccall "hb_font_glyph_to_string" hb_font_glyph_to_string
    :: Font_ -> Word32 -> CString -> Int -> IO ()
fontGlyph2Str :: Font -> Word32 -> Int -> String
fontGlyph2Str font glyph length = unsafePerformIO $
    withForeignPtr font $ \font' -> allocaBytes length $ \ret -> do
        hb_font_glyph_to_string font' glyph ret length
        peekCString ret

data FontExtents = FontExtents {
    ascender :: Int32,
    descender :: Int32,
    lineGap :: Int32
}

instance Storable FontExtents where
    sizeOf _ = sizeOf (undefined :: Int32) * 3
    alignment _ = alignment (undefined :: Int32)
    peek p = do
        let q = castPtr p
        asc <- peek q
        desc <- peekElemOff q 1
        gap <- peekElemOff q 2
        return $ FontExtents asc desc gap
    poke p (FontExtents asc desc gap) = do
        let q = castPtr p
        poke q asc
        pokeElemOff q 1 desc
        pokeElemOff q 2 gap

foreign import ccall "hb_font_get_extents_for_direction"
    hb_font_get_extents_for_direction :: Font_ -> Int -> Ptr FontExtents -> IO ()
fontExtentsForDir :: Font -> Maybe Direction -> FontExtents
fontExtentsForDir font dir = unsafePerformIO $ alloca $ \ret -> do
    withForeignPtr font $ \font' ->
        hb_font_get_extents_for_direction font' (dir2int dir) ret
    peek ret

foreign import ccall "hb_font_get_h_extents" hb_font_get_h_extents
    :: Font_ -> Ptr FontExtents -> IO Bool
fontHExtents font = unsafePerformIO $ alloca $ \ret -> do
    ok <- withForeignPtr font $ \font' -> hb_font_get_h_extents font' ret
    if ok
    then return . Just =<< peek ret
    else return Nothing

foreign import ccall "hb_font_get_v_extents" hb_font_get_v_extents
    :: Font_ -> Ptr FontExtents -> IO Bool
fontVExtents font = unsafePerformIO $ alloca $ \ret -> do
    ok <- withForeignPtr font $ \font' -> hb_font_get_v_extents font' ret
    if ok
    then return . Just =<< peek ret
    else return Nothing

---

data FontOptions = FontOptions {
    optionPPEm :: Maybe (Word, Word),
    optionPtEm :: Maybe Float,
    optionScale :: Maybe (Int, Int)
}
defaultFontOptions = FontOptions {
    optionPPEm = Nothing, optionPtEm = Nothing,
    optionScale = Nothing
}

_setFontOptions font opts = do
    case optionPPEm opts of
        Just (x, y) -> hb_font_set_ppem font x y
        Nothing -> return ()
    case optionPtEm opts of
        Just ptem -> hb_font_set_ptem font ptem
        Nothing -> return ()
    case optionScale opts of
        Just (x, y) -> hb_font_set_scale font x y
        Nothing -> return ()

createFontWithOptions :: FontOptions -> Face -> Font
createFontWithOptions opts fce = unsafePerformIO $ do
    font <- withForeignPtr fce $ hb_font_create
    _setFontOptions font opts
    hb_font_make_immutable font
    Conc.newForeignPtr font $ hb_font_destroy font

ftCreateFontWithOptions :: FontOptions -> FT_Face -> Font
ftCreateFontWithOptions opts fce = unsafePerformIO $ do
    font <- hb_ft_font_create_referenced fce
    _setFontOptions font opts
    hb_font_make_immutable font
    newForeignPtr hb_font_destroy' font

foreign import ccall "hb_font_set_ppem" hb_font_set_ppem :: Font_ -> Word -> Word -> IO ()
foreign import ccall "hb_font_set_ptem" hb_font_set_ptem :: Font_ -> Float -> IO ()
foreign import ccall "hb_font_set_scale" hb_font_set_scale :: Font_ -> Int -> Int -> IO ()

-- Defer implementation of other functions...

---

type Blob = ForeignPtr Blob'
data Blob'
type Blob_ = Ptr Blob'

foreign import ccall "hb_blob_create" hb_blob_create :: Ptr Word8 -> Int -> Int
    -> StablePtr ByteString -> FunPtr (StablePtr ByteString -> IO ()) -> IO Blob_
hb_MEMORY_MODE_READONLY = 1
foreign import ccall "hb_blob_destroy" hb_blob_destroy :: Blob_ -> IO ()
foreign import ccall "wrapper" hs_destructor
    :: (StablePtr a -> IO ()) -> IO (FunPtr (StablePtr a -> IO ()))

bs2blob bytes@(PS ptr offset length) = do
    bytes' <- newStablePtr bytes
    destructor <- hs_destructor freeStablePtr
    blob <- withForeignPtr ptr $ \ptr' ->
        hb_blob_create (plusPtr ptr' offset) (length - offset)
            hb_MEMORY_MODE_READONLY bytes' destructor
    Conc.newForeignPtr blob $ hb_blob_destroy blob

faceFunc :: (Face_ -> a) -> (Face -> a)
faceFunc cb fce = unsafePerformIO $ withForeignPtr fce $ return . cb

fontFunc :: (Font_ -> a) -> (Font -> a)
fontFunc cb fnt = unsafePerformIO $ withForeignPtr fnt $ return . cb

data Set'
type Set = ForeignPtr Set'
type Set_ = Ptr Set'
foreign import ccall "hb_set_create" hb_set_create :: IO Set_
foreign import ccall "&hb_set_destroy" hb_set_destroy :: FunPtr (Set_ -> IO ())

createSet :: IO Set
createSet = do
    ret <- hb_set_create
    newForeignPtr hb_set_destroy ret

foreign import ccall "hb_set_next" hb_set_next :: Set_ -> Ptr Word32 -> IO Bool
setNext :: Set -> Word32 -> Maybe Word32
setNext set iter = unsafePerformIO $ withForeignPtr set $ \set' -> alloca $ \iter' -> do
    poke iter' iter
    success <- hb_set_next set' iter'
    if success
    then return . Just =<< peek iter'
    else return Nothing
set2list :: Set -> IO [Word32]
set2list set = return $ inner maxBound
  where
    inner iter | Just x <- setNext set iter = x : inner x
        | otherwise = []

faceCollectFunc :: (Face_ -> Set_ -> IO ()) -> (Face -> [Word32])
faceCollectFunc cb fce = unsafePerformIO $ withForeignPtr fce $ \fce' -> do
    set <- createSet
    withForeignPtr set $ cb fce'
    set2list set