{-# LINE 1 "src/Termtab/Graphics/FreeType.hsc" #-}
{-# LANGUAGE ForeignFunctionInterface #-}

{- | Minimal FFI binding to the system FreeType library.

We deliberately bind the handful of FreeType entry points we need rather than
depend on the @freetype2@ Hackage package: that package vendors and compiles
FreeType's C source (including a bundled zlib) which does not build on the
hermetic Apple-SDK toolchain. Linking the nixpkgs system @freetype@ via
@pkgconfig-depends: freetype2@ is robust across clang versions.

This is the raw rasterization layer: it turns a glyph (a Unicode code point,
e.g. a SMuFL notehead in Bravura) into an 8-bit grayscale coverage bitmap plus
placement metrics. Glyph caching lives one layer up in "Termtab.Graphics.Font".
-}
module Termtab.Graphics.FreeType (
    FontFace,
    newFontFace,
    freeFontFace,
    withFontFace,
    GlyphBitmap (..),
    renderGlyph,
) where

import Codec.Picture.Types (Image (..), Pixel8)
import Control.Exception (bracket)
import Control.Monad (when)
import Data.Char (ord)
import Data.Vector.Storable qualified as VS
import Data.Vector.Storable.Mutable qualified as VSM
import Data.Word (Word8)
import Foreign
import Foreign.C.String (CString, withCString)
import Foreign.C.Types




type FT_Error = CInt
type FT_Library = Ptr ()
type FT_Face = Ptr ()
type FT_GlyphSlot = Ptr ()

foreign import ccall unsafe "FT_Init_FreeType"
    c_FT_Init_FreeType :: Ptr FT_Library -> IO FT_Error
foreign import ccall unsafe "FT_Done_FreeType"
    c_FT_Done_FreeType :: FT_Library -> IO FT_Error
foreign import ccall unsafe "FT_New_Face"
    c_FT_New_Face :: FT_Library -> CString -> CLong -> Ptr FT_Face -> IO FT_Error
foreign import ccall unsafe "FT_Done_Face"
    c_FT_Done_Face :: FT_Face -> IO FT_Error
foreign import ccall unsafe "FT_Set_Pixel_Sizes"
    c_FT_Set_Pixel_Sizes :: FT_Face -> CUInt -> CUInt -> IO FT_Error
foreign import ccall unsafe "FT_Load_Char"
    c_FT_Load_Char :: FT_Face -> CULong -> CInt -> IO FT_Error

-- | A loaded font face together with the library that owns it.
data FontFace = FontFace FT_Library FT_Face

-- | An 8-bit grayscale coverage bitmap plus FreeType placement metrics.
data GlyphBitmap = GlyphBitmap
    { GlyphBitmap -> Image Word8
gbImage :: Image Pixel8
    -- ^ Coverage: 0 = transparent, 255 = fully inked.
    , GlyphBitmap -> Int
gbLeft :: Int
    -- ^ Horizontal bearing: pixels from the pen x to the bitmap's left edge.
    , GlyphBitmap -> Int
gbTop :: Int
    -- ^ Vertical bearing: pixels from the baseline up to the bitmap's top edge.
    , GlyphBitmap -> Int
gbAdvance :: Int
    -- ^ Horizontal advance in whole pixels.
    }

-- | Load a font face from a file path. Throws via @error@ on failure.
newFontFace :: FilePath -> IO FontFace
newFontFace :: [Char] -> IO FontFace
newFontFace [Char]
path =
    (Ptr FT_GlyphSlot -> IO FontFace) -> IO FontFace
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr FT_GlyphSlot -> IO FontFace) -> IO FontFace)
-> (Ptr FT_GlyphSlot -> IO FontFace) -> IO FontFace
forall a b. (a -> b) -> a -> b
$ \Ptr FT_GlyphSlot
libPtr -> do
        [Char] -> FT_Error -> IO ()
checkFT [Char]
"FT_Init_FreeType" (FT_Error -> IO ()) -> IO FT_Error -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr FT_GlyphSlot -> IO FT_Error
c_FT_Init_FreeType Ptr FT_GlyphSlot
libPtr
        lib <- Ptr FT_GlyphSlot -> IO FT_GlyphSlot
forall a. Storable a => Ptr a -> IO a
peek Ptr FT_GlyphSlot
libPtr
        alloca $ \Ptr FT_GlyphSlot
facePtr -> do
            err <- [Char] -> (CString -> IO FT_Error) -> IO FT_Error
forall a. [Char] -> (CString -> IO a) -> IO a
withCString [Char]
path ((CString -> IO FT_Error) -> IO FT_Error)
-> (CString -> IO FT_Error) -> IO FT_Error
forall a b. (a -> b) -> a -> b
$ \CString
cpath ->
                FT_GlyphSlot -> CString -> CLong -> Ptr FT_GlyphSlot -> IO FT_Error
c_FT_New_Face FT_GlyphSlot
lib CString
cpath CLong
0 Ptr FT_GlyphSlot
facePtr
            when (err /= 0) $ do
                _ <- c_FT_Done_FreeType lib
                checkFT "FT_New_Face" err
            face <- peek facePtr
            pure (FontFace lib face)

-- | Release a font face and its owning library.
freeFontFace :: FontFace -> IO ()
freeFontFace :: FontFace -> IO ()
freeFontFace (FontFace FT_GlyphSlot
lib FT_GlyphSlot
face) = do
    _ <- FT_GlyphSlot -> IO FT_Error
c_FT_Done_Face FT_GlyphSlot
face
    _ <- c_FT_Done_FreeType lib
    pure ()

-- | Bracketed 'newFontFace' / 'freeFontFace'.
withFontFace :: FilePath -> (FontFace -> IO a) -> IO a
withFontFace :: forall a. [Char] -> (FontFace -> IO a) -> IO a
withFontFace [Char]
path = IO FontFace -> (FontFace -> IO ()) -> (FontFace -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket ([Char] -> IO FontFace
newFontFace [Char]
path) FontFace -> IO ()
freeFontFace

{- | Render a single character at the given pixel height. Returns 'Nothing'
only if FreeType could not load/render the glyph. A whitespace glyph with no
ink renders as a 0x0 image (its 'gbAdvance' is still meaningful).
-}
renderGlyph :: FontFace -> Int -> Char -> IO (Maybe GlyphBitmap)
renderGlyph :: FontFace -> Int -> Char -> IO (Maybe GlyphBitmap)
renderGlyph (FontFace FT_GlyphSlot
_ FT_GlyphSlot
face) Int
pixelHeight Char
ch = do
    e1 <- FT_GlyphSlot -> CUInt -> CUInt -> IO FT_Error
c_FT_Set_Pixel_Sizes FT_GlyphSlot
face CUInt
0 (Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pixelHeight)
    if e1 /= 0
        then pure Nothing
        else do
            e2 <- c_FT_Load_Char face (fromIntegral (ord ch)) (4)
{-# LINE 108 "src/Termtab/Graphics/FreeType.hsc" #-}
            if e2 /= 0
                then pure Nothing
                else do
                    slot <- ((\FT_GlyphSlot
hsc_ptr -> FT_GlyphSlot -> Int -> IO FT_GlyphSlot
forall b. Ptr b -> Int -> IO FT_GlyphSlot
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff FT_GlyphSlot
hsc_ptr Int
152)) face :: IO FT_GlyphSlot
{-# LINE 112 "src/Termtab/Graphics/FreeType.hsc" #-}
                    Just <$> readGlyphBitmap slot

-- | Copy the rendered bitmap out of the glyph slot into a JuicyPixels image.
readGlyphBitmap :: FT_GlyphSlot -> IO GlyphBitmap
readGlyphBitmap :: FT_GlyphSlot -> IO GlyphBitmap
readGlyphBitmap FT_GlyphSlot
slot = do
    let bitmap :: Ptr b
bitmap = FT_GlyphSlot
slot FT_GlyphSlot -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` ((Int
152))
{-# LINE 118 "src/Termtab/Graphics/FreeType.hsc" #-}
    rows <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) bitmap :: IO CUInt
{-# LINE 119 "src/Termtab/Graphics/FreeType.hsc" #-}
    width <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) bitmap :: IO CUInt
{-# LINE 120 "src/Termtab/Graphics/FreeType.hsc" #-}
    pitch <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) bitmap :: IO CInt
{-# LINE 121 "src/Termtab/Graphics/FreeType.hsc" #-}
    buffer <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) bitmap :: IO (Ptr Word8)
{-# LINE 122 "src/Termtab/Graphics/FreeType.hsc" #-}
    left <- ((\hsc_ptr -> peekByteOff hsc_ptr 192)) slot :: IO CInt
{-# LINE 123 "src/Termtab/Graphics/FreeType.hsc" #-}
    top <- ((\hsc_ptr -> peekByteOff hsc_ptr 196)) slot :: IO CInt
{-# LINE 124 "src/Termtab/Graphics/FreeType.hsc" #-}
    advance <- ((\hsc_ptr -> peekByteOff hsc_ptr 128)) slot :: IO CLong
{-# LINE 125 "src/Termtab/Graphics/FreeType.hsc" #-}
    let w = fromIntegral width
        h = fromIntegral rows
        p = fromIntegral pitch
    img <- copyBitmap buffer w h p
    pure
        GlyphBitmap
            { gbImage = img
            , gbLeft = fromIntegral left
            , gbTop = fromIntegral top
            , -- FreeType advances are 26.6 fixed point; drop the fractional bits.
              gbAdvance = fromIntegral advance `shiftR` 6
            }

{- | Copy @h@ rows of @w@ grayscale bytes from @buf@ (row stride @pitch@) into a
tightly-packed 'Image' 'Pixel8'. Assumes a top-down 8-bit gray bitmap, which is
what @FT_LOAD_RENDER@ produces by default.
-}
copyBitmap :: Ptr Word8 -> Int -> Int -> Int -> IO (Image Pixel8)
copyBitmap :: Ptr Word8 -> Int -> Int -> Int -> IO (Image Word8)
copyBitmap Ptr Word8
buf Int
w Int
h Int
pitch
    | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Ptr Word8
buf Ptr Word8 -> Ptr Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Word8
forall {b}. Ptr b
nullPtr =
        Image Word8 -> IO (Image Word8)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Vector (PixelBaseComponent Word8) -> Image Word8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
w) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
h) (Int -> Word8 -> Vector Word8
forall a. Storable a => Int -> a -> Vector a
VS.replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
h) Word8
0))
    | Bool
otherwise = do
        mv <- Int -> IO (MVector (PrimState IO) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
VSM.new (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
h)
        let copyRow Int
y =
                let srcRow :: Ptr b
srcRow = Ptr Word8
buf Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
pitch)
                    copyPx :: Int -> IO ()
copyPx Int
x = do
                        b <- Ptr (ZonkAny 0) -> Int -> IO Word8
forall b. Ptr b -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr (ZonkAny 0)
forall {b}. Ptr b
srcRow Int
x :: IO Word8
                        VSM.write mv (y * w + x) b
                 in (Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> IO ()
copyPx [Int
0 .. Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
        mapM_ copyRow [0 .. h - 1]
        frozen <- VS.freeze mv
        pure (Image w h frozen)

-- | Raise an @error@ naming @what@ if a FreeType call returned a nonzero
-- error code.
checkFT :: String -> FT_Error -> IO ()
checkFT :: [Char] -> FT_Error -> IO ()
checkFT [Char]
what FT_Error
err =
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FT_Error
err FT_Error -> FT_Error -> Bool
forall a. Eq a => a -> a -> Bool
/= FT_Error
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char]
what [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" failed with FreeType error code " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> FT_Error -> [Char]
forall a. Show a => a -> [Char]
show FT_Error
err)