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

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

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 Int
countFace :: ByteString -> Int
countFace bytes = unsafePerformIO $ do
    blob <- bs2blob bytes
    withForeignPtr blob hb_face_count

foreign import ccall "hb_face_create" hb_face_create :: Blob_ -> Int -> IO Face_
foreign import ccall "&hb_face_destroy" hb_face_destroy :: FunPtr (Face_ -> IO ())
createFace :: ByteString -> Int -> Face
createFace bytes index = unsafePerformIO $ do
    blob <- bs2blob bytes
    face <- withForeignPtr blob $ flip hb_face_create index
    newForeignPtr 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_glyph_count" hb_face_get_glyph_count :: Face_ -> Int
faceGlyphCount :: Face -> Int
faceGlyphCount = faceFunc hb_face_get_glyph_count

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

foreign import ccall "hb_face_get_upem" hb_face_get_upem :: Face_ -> Int
faceUpem :: Face -> Int
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 :: FunPtr (Font_ -> IO ())
createFont :: Face -> Font
createFont fce = unsafePerformIO $ do
    font <- withForeignPtr fce $ hb_font_create
    hb_font_make_immutable font
    newForeignPtr 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 (GlyphExtents a _ _ _) = 4 * sizeOf a
    alignment (GlyphExtents a _ _ _) = alignment a
    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_ -> Ptr Word8 -> Int -> Ptr Word32 -> IO Bool
fontGlyphFromName :: Font -> ShortText -> Maybe Word32
fontGlyphFromName font name = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \ret -> do
        let PS ptr offset size = toByteString name
        success <- withForeignPtr ptr $ \ptr' ->
            hb_font_get_glyph_from_name font' (plusPtr ptr' offset) (size - offset) 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 -> Word32
fontGlyphHAdvance :: Font -> Word32 -> Word32
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 -> Word32
fontGlyphHKerning :: Font -> Word32 -> Word32 -> Word32
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 Word32 -> Ptr Word32 -> IO Bool
fontGlyphHOrigin :: Font -> Word32 -> Maybe (Word32, Word32)
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 Word32 -> Ptr Word32 -> IO ()
fontGlyphKerningForDir :: Font -> Word32 -> Word32 -> Maybe Direction -> (Word32, Word32)
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 -> Int -> IO Bool
fontGlyphName :: Font -> Word32 -> Int -> Maybe String
fontGlyphName font glyph length = unsafePerformIO $
    withForeignPtr font $ \font' -> allocaBytes length $ \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 Word32 -> Ptr Word32 -> IO ()
fontGlyphOriginForDir :: Font -> Word32 -> Maybe Direction -> (Word32, Word32)
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 -> Word32
fontGlyphVAdvance :: Font -> Word32 -> Word32
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 Word32 -> Ptr Word32 -> IO Bool
fontGlyphVOrigin :: Font -> Word32 -> Maybe (Word32, Word32)
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 Int -> Ptr Int -> IO ()
fontPPEm :: Font -> (Int, Int)
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_var_coords_normalized"
    hb_font_get_var_coords_normalized :: Font_ -> Ptr Int -> 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..length-1] $ peekElemOff arr

foreign import ccall "hb_font_glyph_from_string" hb_font_glyph_from_string
    :: Font_ -> Ptr Word8 -> Int -> Ptr Word32 -> IO Bool
fontTxt2Glyph :: Font -> ShortText -> Maybe Word32
fontTxt2Glyph font txt = unsafePerformIO $
    withForeignPtr font $ \font' -> alloca $ \ret -> do
        let PS ptr offset size = toByteString txt
        ok <- withForeignPtr ptr $ \ptr' ->
            hb_font_glyph_from_string font' (plusPtr ptr' offset) (size - offset) 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 FontOptions = FontOptions {
    optionPPEm :: Maybe (Int, Int),
    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
    newForeignPtr 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_ -> Int -> Int -> 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