-- NOTE: Not tested
module FreeType.FontConfig (ftCharIndex, ftCharSet, ftCharSetAndSpacing,
    ftQuery, ftQueryAll, ftQueryFace) where

import Graphics.Text.Font.Choose.CharSet (CharSet, CharSet_, thawCharSet, thawCharSet_)
import Graphics.Text.Font.Choose.Pattern (Pattern, Pattern_, thawPattern, thawPattern_)
import Graphics.Text.Font.Choose.FontSet (FontSet, FontSet_, withFontSet, thawFontSet)
import FreeType.Core.Base (FT_Face(..))
import Data.Word (Word32, Word)

import Foreign.Ptr (nullPtr, Ptr)
import Foreign.Storable (Storable(..))
import Foreign.Marshal.Alloc (alloca)
import Foreign.C.String (CString, withCString)
import System.IO.Unsafe (unsafePerformIO)

import Control.Exception (throw, catch)
import Graphics.Text.Font.Choose.Result (Error(ErrTypeMismatch))

-- For FcFt transliteration
import Graphics.Text.Font.Choose.Value (Value(..))
import Graphics.Text.Font.Choose.Pattern (getValue', getValue0, getValue, getValues')

import Data.Maybe (fromMaybe)
import Linear.V2 (V2(..))
import Linear.Matrix(M22)
import Data.Bits ((.|.))

import FreeType.Core.Base
import FreeType.Support.Outline (ft_Outline_Embolden)
import FreeType.Control.Subpixel (FT_LcdFilter, ft_Library_SetLcdFilter)
import FreeType.Core.Types
import FreeType.Exception (FtError(..))

c2w :: Char -> Word32
c2w = fromIntegral . fromEnum

ftCharIndex :: FT_Face -> Char -> Word
ftCharIndex face = fcFreeTypeCharIndex face . c2w
foreign import ccall "FcFreeTypeCharIndex" fcFreeTypeCharIndex :: FT_Face -> Word32 -> Word

ftCharSet :: FT_Face -> CharSet
ftCharSet face = unsafePerformIO $ thawCharSet_ $ fcFreeTypeCharSet face nullPtr
foreign import ccall "FcFreeTypeCharSet" fcFreeTypeCharSet
    :: FT_Face -> Ptr () -> IO CharSet_ -- 2nd arg's deprecated!

data Spacing = Proportional | Dual | Mono
ftCharSetAndSpacing :: FT_Face -> (CharSet, Spacing)
ftCharSetAndSpacing face = unsafePerformIO $ alloca $ \spacing' -> do
    chars <- thawCharSet_ $ fcFreeTypeCharSetAndSpacing face nullPtr spacing'
    spacing_ <- peek spacing'
    let spacing = case spacing_ of{
        0 -> Proportional;
        90 -> Dual;
        100 -> Mono;
        _ -> throw ErrTypeMismatch}
    return (chars, spacing)
foreign import ccall "FcFreeTypeCharSetAndSpacing" fcFreeTypeCharSetAndSpacing ::
    FT_Face -> Ptr () -> Ptr Int -> IO CharSet_ -- 2nd arg's deprecated!

ftQuery :: FilePath -> Int -> IO (Pattern, Int)
ftQuery filename id = withCString filename $ \filename' -> alloca $ \count' -> do
    pattern <- thawPattern_ $ fcFreeTypeQuery filename' id nullPtr count'
    count <- peek count'
    return (pattern, count)
foreign import ccall "FcFreeTypeQuery" fcFreeTypeQuery ::
    CString -> Int -> Ptr () -> Ptr Int -> IO Pattern_ -- 3rd arg's deprecated!

ftQueryAll :: FilePath -> Int -> IO (FontSet, Int)
ftQueryAll filename id = withCString filename $ \filename' -> alloca $ \count' ->
    withFontSet [] $ \fonts' -> do
        fcFreeTypeQueryAll filename' id nullPtr count' fonts'
        fonts <- thawFontSet fonts'
        count <- peek count'
        return (fonts, count)
foreign import ccall "FcFreeTypeQueryAll" fcFreeTypeQueryAll ::
    CString -> Int -> Ptr () -> Ptr Int -> FontSet_ -> IO Word -- 2nd arg's deprecated!

ftQueryFace :: FT_Face -> FilePath -> Int -> IO Pattern
ftQueryFace face filename id = withCString filename $ \filename' ->
    thawPattern_ $ fcFreeTypeQueryFace face filename' id nullPtr
foreign import ccall "FcFreeTypeQueryFace" fcFreeTypeQueryFace ::
    FT_Face -> CString -> Int -> Ptr () -> IO Pattern_ -- Final arg's deprecated!

------
--- Transliterated from FcFt
--- https://codeberg.org/dnkl/fcft/
--- Untested
------

data FTFC_Instance = Instance {
    fontName :: String,
    fontPath :: Maybe String,
    fontFace :: FT_Face,
    fontLoadFlags :: Int,
    fontAntialias :: Bool,
    fontEmbolden :: Bool,
    fontIsColor :: Bool,
    fontRenderFlags :: Int,
    fontRenderFlagsSubpixel :: Int,
    fontPixelSizeFixup :: Double,
    fontPixelFixupEstimated :: Bool,
    fontBGR :: Bool,
    fontLCDFilter :: FT_LcdFilter,
    fontFeats :: [String], -- Callers probably want to validate via harfbuzz
    fontMetrics :: FTFC_Metrics
}
data FTFC_Metrics = Metrics {
    height :: Int,
    descent :: Int,
    ascent :: Int,
    maxAdvance :: (Int, Int),
    metricsAntialias :: Bool,
    metricsSubpixel :: FTFC_Subpixel,
    metricsName :: String
}
data FTFC_Subpixel = SubpixelNone | SubpixelHorizontalRGB | SubpixelHorizontalBGR |
    SubpixelVerticalRGB | SubpixelVerticalBGR | SubpixelDefault

instantiatePattern :: FT_Library -> Pattern -> (Double, Double) -> IO FTFC_Instance
instantiatePattern ftlib pattern (req_pt_size, req_px_size) = do
    let dpi = fromMaybe 75 $ getValue' "dpi" pattern :: Double
    let size = fromMaybe req_pt_size $ getValue' "size" pattern

    ft_face <- case getValue "ftface" pattern of
        ValueFTFace x -> return x
        _ -> ft_New_Face ftlib (getValue0 "file" pattern) -- is a mutex needed?
            (toEnum $ fromMaybe 0 $ getValue' "index" pattern)

    ft_Set_Pixel_Sizes ft_face 0 $ toEnum $ getValue0 "pixelsize" pattern
    let scalable = fromMaybe True $ getValue' "scalable" pattern
    let outline = fromMaybe True $ getValue' "outline" pattern
    (pixel_fixup, fixup_estimated) <- case getValue "pixelsizefixupfactor" pattern of
        ValueDouble x -> return (x, False)
        _ | scalable && not outline -> do
            let px_size = if req_px_size < 0 then req_pt_size * dpi / 72 else req_px_size
            ft_face' <- peek ft_face
            size' <- peek $ frSize ft_face'
            return (px_size / (fromIntegral $ smY_ppem $ srMetrics size'), True)
        _ -> return (1, False)

    let hinting = fromMaybe True $ getValue' "hinting" pattern
    let antialias = fromMaybe True $ getValue' "antialias" pattern
    let hintstyle = fromMaybe 1 $ getValue' "hintstyle" pattern :: Int
    let rgba = fromMaybe 0 $ getValue' "rgba" pattern :: Int
    let load_flags | not antialias && (not hinting || hintstyle == 0) =
                        ft_LOAD_NO_HINTING .|. ft_LOAD_MONOCHROME
                   | not antialias = ft_LOAD_MONOCHROME
                   | not hinting || hintstyle == 0 = ft_LOAD_NO_HINTING
                   | otherwise = ft_LOAD_DEFAULT
    let load_target | not antialias && hinting && hintstyle /= 0 = ft_LOAD_TARGET_MONO
                    | not antialias = ft_LOAD_TARGET_NORMAL
                    | not hinting || hintstyle == 0 = ft_LOAD_TARGET_NORMAL
                    | hintstyle == 1 = ft_LOAD_TARGET_LIGHT
                    | hintstyle == 2 = ft_LOAD_TARGET_NORMAL
                    | rgba `elem` [1, 2] = ft_LOAD_TARGET_LCD
                    | rgba `elem` [3, 4] = ft_LOAD_TARGET_LCD_V
                    | otherwise = ft_LOAD_TARGET_NORMAL

    let embedded_bitmap = fromMaybe True $ getValue' "embeddedbitmap" pattern
    let load_flags1 | embedded_bitmap = load_flags .|. ft_LOAD_NO_BITMAP
                    | otherwise = load_flags
    let autohint = fromMaybe False $ getValue' "autohint" pattern
    let load_flags2 | autohint = load_flags .|. ft_LOAD_FORCE_AUTOHINT
                    | otherwise = load_flags
    let render_flags_normal | not antialias = ft_RENDER_MODE_MONO
                            | otherwise = ft_RENDER_MODE_NORMAL
    let render_flags_subpixel | not antialias = ft_RENDER_MODE_MONO
                              | rgba `elem` [1, 2] = ft_RENDER_MODE_LCD
                              | rgba `elem` [3, 4] = ft_RENDER_MODE_LCD_V
                              | otherwise = ft_RENDER_MODE_NORMAL

    let lcdfilter = case fromMaybe 1 $ getValue' "lcdfilter" pattern :: Int of {
        3 -> 16; x -> x}
    case getValue "matrix" pattern of
        ValueMatrix m -> ft_Set_Transform ft_face (Just $ m22toFt m) Nothing
        _ -> return ()

    ft_face' <- peek ft_face
    size' <- peek $ frSize ft_face'
    let metrics' = srMetrics size'
    let c x = fromIntegral x / 64 * pixel_fixup
    return Instance {
        fontName = getValue0 "fullname" pattern,
        fontPath = getValue' "file" pattern,
        fontFace = ft_face,
        fontLoadFlags = load_target .|. load_flags .|. ft_LOAD_COLOR,
        fontAntialias = antialias,
        fontEmbolden = fromMaybe False $ getValue' "embolden" pattern,
        fontIsColor = fromMaybe False $ getValue' "color" pattern,
        fontRenderFlags = render_flags_normal,
        fontRenderFlagsSubpixel = render_flags_subpixel,
        fontPixelSizeFixup = pixel_fixup,
        fontPixelFixupEstimated = fixup_estimated,
        fontBGR = rgba `elem` [2, 4],
        fontLCDFilter = toEnum lcdfilter,
        fontFeats = getValues' "fontfeatures" pattern,
        fontMetrics = Metrics {
            height = fromEnum $ c $ smHeight metrics',
            descent = fromEnum $ c $ smDescender metrics',
            ascent = fromEnum $ c $ smAscender metrics',
            maxAdvance = (fromEnum $ c $ smMax_advance metrics',
                fromEnum $ c $ smHeight metrics'),
            metricsAntialias = antialias,
            metricsSubpixel = case rgba of
                _ | not antialias -> SubpixelNone
                1 -> SubpixelHorizontalRGB
                2 -> SubpixelHorizontalBGR
                3 -> SubpixelVerticalRGB
                4 -> SubpixelVerticalBGR
                _ -> SubpixelNone,
            metricsName = getValue0 "fullname" pattern
        }
      }

data FTFC_Glyph a = Glyph {
    glyphFontName :: String,
    glyphImage :: a,
    glyphAdvance :: (Double, Double),
    glyphSubpixel :: FTFC_Subpixel
}

glyphForIndex :: FTFC_Instance -> Word32 -> FTFC_Subpixel -> 
    (FT_Bitmap -> IO a) -> IO (FTFC_Glyph a)
glyphForIndex font index subpixel cb = do
    ft_Load_Glyph (fontFace font) index (toEnum $ fontLoadFlags font)
    face' <- peek $ fontFace font
    size' <- peek $ frSize face'
    -- Formula from old FreeType function `FT_GlyphSlotEmbolden`.
    -- Approximate as fallback for fonts not using fontsets or variables axis.
    let strength = fromIntegral (frUnits_per_EM face')*smY_scale (srMetrics size')`div`24
    glyph' <- peek $ frGlyph face'

    glyph1' <- case gsrFormat glyph' of
        FT_GLYPH_FORMAT_OUTLINE | fontEmbolden font -> do
            outline <- withPtr (gsrOutline glyph') $ flip ft_Outline_Embolden strength
            return glyph' { gsrOutline = outline }
        _ -> return glyph'

    let render_flags = case subpixel of {
-- FT_GLYPH_FORMAT_SVG is not exposed by our language bindings,
-- Should be largely irrelevant now... Certain FreeType versions required this flag.
--        _ | FT_GLYPH_FORMAT_SVG <- gsrFormat glyph1' -> ft_RENDER_MODE_NORMAL;
        _ | not $ fontAntialias font -> fontRenderFlags font;
        SubpixelNone -> fontRenderFlags font;
        SubpixelHorizontalRGB -> ft_RENDER_MODE_LCD;
        SubpixelHorizontalBGR -> ft_RENDER_MODE_LCD;
        SubpixelVerticalRGB -> ft_RENDER_MODE_LCD_V;
        SubpixelVerticalBGR -> ft_RENDER_MODE_LCD_V;
        SubpixelDefault -> fontRenderFlagsSubpixel font}
    let bgr = case subpixel of {
        _ | not $ fontAntialias font -> False;
        SubpixelNone -> False;
        SubpixelHorizontalRGB -> False;
        SubpixelHorizontalBGR -> True;
        SubpixelVerticalRGB -> False;
        SubpixelVerticalBGR -> True;
        SubpixelDefault -> fontBGR font}

    can_set_lcd_filter <- isSuccess $ ft_Library_SetLcdFilter (gsrLibrary glyph1') 0
    -- FIXME: Do we need a mutex?
    let set_lcd_filter = ft_Library_SetLcdFilter (gsrLibrary glyph1') $ fontLCDFilter font
    case render_flags of {
        FT_RENDER_MODE_LCD | can_set_lcd_filter -> set_lcd_filter;
        FT_RENDER_MODE_LCD_V | can_set_lcd_filter -> set_lcd_filter;
        _ -> return ()}

    glyph2' <- case gsrFormat glyph1' of {
        FT_GLYPH_FORMAT_BITMAP -> return glyph1';
        _ -> withPtr glyph1' $ flip ft_Render_Glyph $ toEnum render_flags}
    -- If set_lcd_filter requires mutex, release it here.
    case gsrFormat glyph2' of {
        FT_GLYPH_FORMAT_BITMAP -> return ();
        _ -> throw $ FtError "glyphForIndex" 2
    }

    img <- cb $ gsrBitmap glyph2'
    return Glyph {
        glyphFontName = fontName font, glyphImage = img,
        glyphAdvance = (fromIntegral (vX $ gsrAdvance glyph2') / 64 *
            if fontPixelFixupEstimated font then fontPixelSizeFixup font else 1,
            fromIntegral (vY $ gsrAdvance glyph2') / 64 *
            if fontPixelFixupEstimated font then fontPixelSizeFixup font else 1),
        glyphSubpixel = subpixel
    }

withPtr :: Storable a => a -> (Ptr a -> IO b) -> IO a
withPtr a cb = alloca $ \a' -> do
    poke a' a
    cb a'
    peek a'

isSuccess :: IO a -> IO Bool
isSuccess cb = do
    cb
    return True
  `catch` \(FtError _ _) -> return False

m22toFt :: M22 Double -> FT_Matrix
m22toFt (V2 (V2 xx xy) (V2 yx yy)) = FT_Matrix {
    mXx = c xx * 0x10000, mXy = c xy * 0x10000,
    mYx = c yx * 0x10000, mYy = c yy * 0x10000
  } where c = toEnum . fromEnum

-- Taken from FreeType language bindings,
-- but converted to constants rather than pattern synonyms.
ft_LOAD_DEFAULT, ft_LOAD_NO_SCALE, ft_LOAD_NO_HINTING, ft_LOAD_RENDER,
    ft_LOAD_NO_BITMAP, ft_LOAD_VERTICAL_LAYOUT, ft_LOAD_FORCE_AUTOHINT,
    ft_LOAD_CROP_BITMAP, ft_LOAD_PEDANTIC, ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH,
    ft_LOAD_NO_RECURSE, ft_LOAD_IGNORE_TRANSFORM, ft_LOAD_MONOCHROME,
    ft_LOAD_LINEAR_DESIGN, ft_LOAD_NO_AUTOHINT, ft_LOAD_COLOR,
    ft_LOAD_COMPUTE_METRICS, ft_LOAD_BITMAP_METRICS_ONLY :: Int
ft_LOAD_DEFAULT                     = 0
ft_LOAD_NO_SCALE                    = 1
ft_LOAD_NO_HINTING                  = 2
ft_LOAD_RENDER                      = 4
ft_LOAD_NO_BITMAP                   = 8
ft_LOAD_VERTICAL_LAYOUT             = 16
ft_LOAD_FORCE_AUTOHINT              = 32
ft_LOAD_CROP_BITMAP                 = 64
ft_LOAD_PEDANTIC                    = 128
ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH = 512
ft_LOAD_NO_RECURSE                  = 1024
ft_LOAD_IGNORE_TRANSFORM            = 2048
ft_LOAD_MONOCHROME                  = 4096
ft_LOAD_LINEAR_DESIGN               = 8192
ft_LOAD_NO_AUTOHINT                 = 32768
ft_LOAD_COLOR                       = 1048576
ft_LOAD_COMPUTE_METRICS             = 2097152
ft_LOAD_BITMAP_METRICS_ONLY         = 4194304

ft_LOAD_TARGET_NORMAL, ft_LOAD_TARGET_LIGHT, ft_LOAD_TARGET_MONO,
    ft_LOAD_TARGET_LCD, ft_LOAD_TARGET_LCD_V :: Int
ft_LOAD_TARGET_NORMAL = 0
ft_LOAD_TARGET_LIGHT  = 65536
ft_LOAD_TARGET_MONO   = 131072
ft_LOAD_TARGET_LCD    = 196608
ft_LOAD_TARGET_LCD_V  = 262144

ft_RENDER_MODE_NORMAL, ft_RENDER_MODE_LIGHT, ft_RENDER_MODE_MONO,
    ft_RENDER_MODE_LCD, ft_RENDER_MODE_LCD_V :: Int
ft_RENDER_MODE_NORMAL = 0
ft_RENDER_MODE_LIGHT  = 1
ft_RENDER_MODE_MONO   = 2
ft_RENDER_MODE_LCD    = 3
ft_RENDER_MODE_LCD_V  = 4