module FreeType.FontConfig (ftCharIndex, ftCharSet, ftCharSetAndSpacing,
ftQuery, ftQueryAll, ftQueryFace,
FTFC_Instance(..), FTFC_Metrics(..), FTFC_Subpixel(..), instantiatePattern,
FTFC_Glyph(..), glyphForIndex, bmpAndMetricsForIndex) 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))
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 :: Char -> FT_UInt
c2w = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum
ftCharIndex :: FT_Face -> Char -> Word
ftCharIndex :: FT_Face -> Char -> Word
ftCharIndex FT_Face
face = FT_Face -> FT_UInt -> Word
fcFreeTypeCharIndex FT_Face
face forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> FT_UInt
c2w
foreign import ccall "FcFreeTypeCharIndex" fcFreeTypeCharIndex :: FT_Face -> Word32 -> Word
ftCharSet :: FT_Face -> CharSet
ftCharSet :: FT_Face -> CharSet
ftCharSet FT_Face
face = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ IO CharSet_ -> IO CharSet
thawCharSet_ forall a b. (a -> b) -> a -> b
$ FT_Face -> Ptr () -> IO CharSet_
fcFreeTypeCharSet FT_Face
face forall a. Ptr a
nullPtr
foreign import ccall "FcFreeTypeCharSet" fcFreeTypeCharSet
:: FT_Face -> Ptr () -> IO CharSet_
data Spacing = Proportional
| Dual
| Mono
ftCharSetAndSpacing :: FT_Face -> (CharSet, Spacing)
ftCharSetAndSpacing :: FT_Face -> (CharSet, Spacing)
ftCharSetAndSpacing FT_Face
face = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr Int
spacing' -> do
CharSet
chars <- IO CharSet_ -> IO CharSet
thawCharSet_ forall a b. (a -> b) -> a -> b
$ FT_Face -> Ptr () -> Ptr Int -> IO CharSet_
fcFreeTypeCharSetAndSpacing FT_Face
face forall a. Ptr a
nullPtr Ptr Int
spacing'
Int
spacing_ <- forall a. Storable a => Ptr a -> IO a
peek Ptr Int
spacing'
let spacing :: Spacing
spacing = case Int
spacing_ of{
Int
0 -> Spacing
Proportional;
Int
90 -> Spacing
Dual;
Int
100 -> Spacing
Mono;
Int
_ -> forall a e. Exception e => e -> a
throw Error
ErrTypeMismatch}
forall (m :: * -> *) a. Monad m => a -> m a
return (CharSet
chars, Spacing
spacing)
foreign import ccall "FcFreeTypeCharSetAndSpacing" fcFreeTypeCharSetAndSpacing ::
FT_Face -> Ptr () -> Ptr Int -> IO CharSet_
ftQuery :: FilePath -> Int -> IO (Pattern, Int)
ftQuery :: FilePath -> Int -> IO (Pattern, Int)
ftQuery FilePath
filename Int
id = forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
filename forall a b. (a -> b) -> a -> b
$ \CString
filename' -> forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr Int
count' -> do
Pattern
pattern <- IO (Ptr Pattern') -> IO Pattern
thawPattern_ forall a b. (a -> b) -> a -> b
$ CString -> Int -> Ptr () -> Ptr Int -> IO (Ptr Pattern')
fcFreeTypeQuery CString
filename' Int
id forall a. Ptr a
nullPtr Ptr Int
count'
Int
count <- forall a. Storable a => Ptr a -> IO a
peek Ptr Int
count'
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern
pattern, Int
count)
foreign import ccall "FcFreeTypeQuery" fcFreeTypeQuery ::
CString -> Int -> Ptr () -> Ptr Int -> IO Pattern_
ftQueryAll :: FilePath -> Int -> IO (FontSet, Int)
ftQueryAll :: FilePath -> Int -> IO (FontSet, Int)
ftQueryAll FilePath
filename Int
id = forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
filename forall a b. (a -> b) -> a -> b
$ \CString
filename' -> forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr Int
count' ->
forall a. FontSet -> (FontSet_ -> IO a) -> IO a
withFontSet [] forall a b. (a -> b) -> a -> b
$ \FontSet_
fonts' -> do
CString -> Int -> Ptr () -> Ptr Int -> FontSet_ -> IO Word
fcFreeTypeQueryAll CString
filename' Int
id forall a. Ptr a
nullPtr Ptr Int
count' FontSet_
fonts'
FontSet
fonts <- FontSet_ -> IO FontSet
thawFontSet FontSet_
fonts'
Int
count <- forall a. Storable a => Ptr a -> IO a
peek Ptr Int
count'
forall (m :: * -> *) a. Monad m => a -> m a
return (FontSet
fonts, Int
count)
foreign import ccall "FcFreeTypeQueryAll" fcFreeTypeQueryAll ::
CString -> Int -> Ptr () -> Ptr Int -> FontSet_ -> IO Word
ftQueryFace :: FT_Face -> FilePath -> Int -> IO Pattern
ftQueryFace :: FT_Face -> FilePath -> Int -> IO Pattern
ftQueryFace FT_Face
face FilePath
filename Int
id = forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
filename forall a b. (a -> b) -> a -> b
$ \CString
filename' ->
IO (Ptr Pattern') -> IO Pattern
thawPattern_ forall a b. (a -> b) -> a -> b
$ FT_Face -> CString -> Int -> Ptr () -> IO (Ptr Pattern')
fcFreeTypeQueryFace FT_Face
face CString
filename' Int
id forall a. Ptr a
nullPtr
foreign import ccall "FcFreeTypeQueryFace" fcFreeTypeQueryFace ::
FT_Face -> CString -> Int -> Ptr () -> IO Pattern_
data FTFC_Instance = Instance {
FTFC_Instance -> Maybe FilePath
fontName :: Maybe String,
FTFC_Instance -> Maybe FilePath
fontPath :: Maybe String,
FTFC_Instance -> FT_Face
fontFace :: FT_Face,
FTFC_Instance -> Int
fontLoadFlags :: Int,
FTFC_Instance -> Bool
fontAntialias :: Bool,
FTFC_Instance -> Bool
fontEmbolden :: Bool,
FTFC_Instance -> Bool
fontIsColor :: Bool,
FTFC_Instance -> Int
fontRenderFlags :: Int,
FTFC_Instance -> Int
fontRenderFlagsSubpixel :: Int,
FTFC_Instance -> Double
fontPixelSizeFixup :: Double,
FTFC_Instance -> Bool
fontPixelFixupEstimated :: Bool,
FTFC_Instance -> Bool
fontBGR :: Bool,
FTFC_Instance -> FT_UInt
fontLCDFilter :: FT_LcdFilter,
FTFC_Instance -> [FilePath]
fontFeats :: [String],
FTFC_Instance -> FTFC_Metrics
fontMetrics :: FTFC_Metrics
}
data FTFC_Metrics = Metrics {
FTFC_Metrics -> Int
height :: Int,
FTFC_Metrics -> Int
descent :: Int,
FTFC_Metrics -> Int
ascent :: Int,
FTFC_Metrics -> (Int, Int)
maxAdvance :: (Int, Int),
FTFC_Metrics -> Bool
metricsAntialias :: Bool,
FTFC_Metrics -> FTFC_Subpixel
metricsSubpixel :: FTFC_Subpixel,
FTFC_Metrics -> Maybe FilePath
metricsName :: Maybe String
}
data FTFC_Subpixel = SubpixelNone
| SubpixelHorizontalRGB | SubpixelHorizontalBGR |
SubpixelVerticalRGB | SubpixelVerticalBGR
| SubpixelDefault
instantiatePattern :: FT_Library -> Pattern -> (Double, Double) -> IO FTFC_Instance
instantiatePattern :: FT_Library -> Pattern -> (Double, Double) -> IO FTFC_Instance
instantiatePattern FT_Library
ftlib Pattern
pattern (Double
req_pt_size, Double
req_px_size) = do
let dpi :: Double
dpi = forall a. a -> Maybe a -> a
fromMaybe Double
75 forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"dpi" Pattern
pattern :: Double
FT_Face
ft_face <- case FilePath -> Pattern -> Value
getValue FilePath
"ftface" Pattern
pattern of
ValueFTFace FT_Face
x -> forall (m :: * -> *) a. Monad m => a -> m a
return FT_Face
x
Value
_ -> FT_Library -> FilePath -> FT_Fixed -> IO FT_Face
ft_New_Face FT_Library
ftlib (forall x. ToValue x => FilePath -> Pattern -> x
getValue0 FilePath
"file" Pattern
pattern)
(forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"index" Pattern
pattern)
FT_Face -> FT_UInt -> FT_UInt -> IO ()
ft_Set_Pixel_Sizes FT_Face
ft_face FT_UInt
0 forall a b. (a -> b) -> a -> b
$ forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$
forall a. a -> Maybe a -> a
fromMaybe Double
req_px_size forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"pixelsize" Pattern
pattern
let scalable :: Bool
scalable = forall a. a -> Maybe a -> a
fromMaybe Bool
True forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"scalable" Pattern
pattern
let outline :: Bool
outline = forall a. a -> Maybe a -> a
fromMaybe Bool
True forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"outline" Pattern
pattern
(Double
pixel_fixup, Bool
fixup_estimated) <- case FilePath -> Pattern -> Value
getValue FilePath
"pixelsizefixupfactor" Pattern
pattern of
ValueDouble Double
x -> forall (m :: * -> *) a. Monad m => a -> m a
return (Double
x, Bool
False)
Value
_ | Bool
scalable Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
outline -> do
let px_size :: Double
px_size = if Double
req_px_size forall a. Ord a => a -> a -> Bool
< Double
0 then Double
req_pt_size forall a. Num a => a -> a -> a
* Double
dpi forall a. Fractional a => a -> a -> a
/ Double
72 else Double
req_px_size
FT_FaceRec
ft_face' <- forall a. Storable a => Ptr a -> IO a
peek FT_Face
ft_face
FT_SizeRec
size' <- forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ FT_FaceRec -> FT_Size
frSize FT_FaceRec
ft_face'
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
px_size forall a. Fractional a => a -> a -> a
/ (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ FT_Size_Metrics -> FT_UShort
smY_ppem forall a b. (a -> b) -> a -> b
$ FT_SizeRec -> FT_Size_Metrics
srMetrics FT_SizeRec
size'), Bool
True)
Value
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Double
1, Bool
False)
let hinting :: Bool
hinting = forall a. a -> Maybe a -> a
fromMaybe Bool
True forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"hinting" Pattern
pattern
let antialias :: Bool
antialias = forall a. a -> Maybe a -> a
fromMaybe Bool
True forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"antialias" Pattern
pattern
let hintstyle :: Int
hintstyle = forall a. a -> Maybe a -> a
fromMaybe Int
1 forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"hintstyle" Pattern
pattern :: Int
let rgba :: Int
rgba = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"rgba" Pattern
pattern :: Int
let load_flags :: Int
load_flags | Bool -> Bool
not Bool
antialias Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
hinting Bool -> Bool -> Bool
|| Int
hintstyle forall a. Eq a => a -> a -> Bool
== Int
0) =
Int
ft_LOAD_NO_HINTING forall a. Bits a => a -> a -> a
.|. Int
ft_LOAD_MONOCHROME
| Bool -> Bool
not Bool
antialias = Int
ft_LOAD_MONOCHROME
| Bool -> Bool
not Bool
hinting Bool -> Bool -> Bool
|| Int
hintstyle forall a. Eq a => a -> a -> Bool
== Int
0 = Int
ft_LOAD_NO_HINTING
| Bool
otherwise = Int
ft_LOAD_DEFAULT
let load_target :: Int
load_target | Bool -> Bool
not Bool
antialias Bool -> Bool -> Bool
&& Bool
hinting Bool -> Bool -> Bool
&& Int
hintstyle forall a. Eq a => a -> a -> Bool
/= Int
0 = Int
ft_LOAD_TARGET_MONO
| Bool -> Bool
not Bool
antialias = Int
ft_LOAD_TARGET_NORMAL
| Bool -> Bool
not Bool
hinting Bool -> Bool -> Bool
|| Int
hintstyle forall a. Eq a => a -> a -> Bool
== Int
0 = Int
ft_LOAD_TARGET_NORMAL
| Int
hintstyle forall a. Eq a => a -> a -> Bool
== Int
1 = Int
ft_LOAD_TARGET_LIGHT
| Int
hintstyle forall a. Eq a => a -> a -> Bool
== Int
2 = Int
ft_LOAD_TARGET_NORMAL
| Int
rgba forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
1, Int
2] = Int
ft_LOAD_TARGET_LCD
| Int
rgba forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
3, Int
4] = Int
ft_LOAD_TARGET_LCD_V
| Bool
otherwise = Int
ft_LOAD_TARGET_NORMAL
let embedded_bitmap :: Bool
embedded_bitmap = forall a. a -> Maybe a -> a
fromMaybe Bool
True forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"embeddedbitmap" Pattern
pattern
let load_flags1 :: Int
load_flags1 | Bool
embedded_bitmap = Int
load_flags forall a. Bits a => a -> a -> a
.|. Int
ft_LOAD_NO_BITMAP
| Bool
otherwise = Int
load_flags
let autohint :: Bool
autohint = forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"autohint" Pattern
pattern
let load_flags2 :: Int
load_flags2 | Bool
autohint = Int
load_flags forall a. Bits a => a -> a -> a
.|. Int
ft_LOAD_FORCE_AUTOHINT
| Bool
otherwise = Int
load_flags
let render_flags_normal :: Int
render_flags_normal | Bool -> Bool
not Bool
antialias = Int
ft_RENDER_MODE_MONO
| Bool
otherwise = Int
ft_RENDER_MODE_NORMAL
let render_flags_subpixel :: Int
render_flags_subpixel | Bool -> Bool
not Bool
antialias = Int
ft_RENDER_MODE_MONO
| Int
rgba forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
1, Int
2] = Int
ft_RENDER_MODE_LCD
| Int
rgba forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
3, Int
4] = Int
ft_RENDER_MODE_LCD_V
| Bool
otherwise = Int
ft_RENDER_MODE_NORMAL
let lcdfilter :: Int
lcdfilter = case forall a. a -> Maybe a -> a
fromMaybe Int
1 forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"lcdfilter" Pattern
pattern :: Int of {
Int
3 -> Int
16; Int
x -> Int
x}
case FilePath -> Pattern -> Value
getValue FilePath
"matrix" Pattern
pattern of
ValueMatrix M22 Double
m -> FT_Face -> Maybe FT_Matrix -> Maybe FT_Vector -> IO ()
ft_Set_Transform FT_Face
ft_face (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ M22 Double -> FT_Matrix
m22toFt M22 Double
m) forall a. Maybe a
Nothing
Value
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
FT_FaceRec
ft_face' <- forall a. Storable a => Ptr a -> IO a
peek FT_Face
ft_face
FT_SizeRec
size' <- forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ FT_FaceRec -> FT_Size
frSize FT_FaceRec
ft_face'
let metrics' :: FT_Size_Metrics
metrics' = FT_SizeRec -> FT_Size_Metrics
srMetrics FT_SizeRec
size'
let c :: a -> Double
c a
x = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x forall a. Fractional a => a -> a -> a
/ Double
64 forall a. Num a => a -> a -> a
* Double
pixel_fixup
forall (m :: * -> *) a. Monad m => a -> m a
return Instance {
fontName :: Maybe FilePath
fontName = forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"fullname" Pattern
pattern,
fontPath :: Maybe FilePath
fontPath = forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"file" Pattern
pattern,
fontFace :: FT_Face
fontFace = FT_Face
ft_face,
fontLoadFlags :: Int
fontLoadFlags = Int
load_target forall a. Bits a => a -> a -> a
.|. Int
load_flags forall a. Bits a => a -> a -> a
.|. Int
ft_LOAD_COLOR,
fontAntialias :: Bool
fontAntialias = Bool
antialias,
fontEmbolden :: Bool
fontEmbolden = forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"embolden" Pattern
pattern,
fontIsColor :: Bool
fontIsColor = forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"color" Pattern
pattern,
fontRenderFlags :: Int
fontRenderFlags = Int
render_flags_normal,
fontRenderFlagsSubpixel :: Int
fontRenderFlagsSubpixel = Int
render_flags_subpixel,
fontPixelSizeFixup :: Double
fontPixelSizeFixup = Double
pixel_fixup,
fontPixelFixupEstimated :: Bool
fontPixelFixupEstimated = Bool
fixup_estimated,
fontBGR :: Bool
fontBGR = Int
rgba forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
2, Int
4],
fontLCDFilter :: FT_UInt
fontLCDFilter = forall a. Enum a => Int -> a
toEnum Int
lcdfilter,
fontFeats :: [FilePath]
fontFeats = forall {b}. ToValue b => FilePath -> Pattern -> [b]
getValues' FilePath
"fontfeatures" Pattern
pattern,
fontMetrics :: FTFC_Metrics
fontMetrics = Metrics {
height :: Int
height = forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ forall {a}. Integral a => a -> Double
c forall a b. (a -> b) -> a -> b
$ FT_Size_Metrics -> FT_Fixed
smHeight FT_Size_Metrics
metrics',
descent :: Int
descent = forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ forall {a}. Integral a => a -> Double
c forall a b. (a -> b) -> a -> b
$ FT_Size_Metrics -> FT_Fixed
smDescender FT_Size_Metrics
metrics',
ascent :: Int
ascent = forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ forall {a}. Integral a => a -> Double
c forall a b. (a -> b) -> a -> b
$ FT_Size_Metrics -> FT_Fixed
smAscender FT_Size_Metrics
metrics',
maxAdvance :: (Int, Int)
maxAdvance = (forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ forall {a}. Integral a => a -> Double
c forall a b. (a -> b) -> a -> b
$ FT_Size_Metrics -> FT_Fixed
smMax_advance FT_Size_Metrics
metrics',
forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ forall {a}. Integral a => a -> Double
c forall a b. (a -> b) -> a -> b
$ FT_Size_Metrics -> FT_Fixed
smHeight FT_Size_Metrics
metrics'),
metricsAntialias :: Bool
metricsAntialias = Bool
antialias,
metricsSubpixel :: FTFC_Subpixel
metricsSubpixel = case Int
rgba of
Int
_ | Bool -> Bool
not Bool
antialias -> FTFC_Subpixel
SubpixelNone
Int
1 -> FTFC_Subpixel
SubpixelHorizontalRGB
Int
2 -> FTFC_Subpixel
SubpixelHorizontalBGR
Int
3 -> FTFC_Subpixel
SubpixelVerticalRGB
Int
4 -> FTFC_Subpixel
SubpixelVerticalBGR
Int
_ -> FTFC_Subpixel
SubpixelNone,
metricsName :: Maybe FilePath
metricsName = forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"fullname" Pattern
pattern
}
}
data FTFC_Glyph a = Glyph {
forall a. FTFC_Glyph a -> Maybe FilePath
glyphFontName :: Maybe String,
forall a. FTFC_Glyph a -> a
glyphImage :: a,
forall a. FTFC_Glyph a -> (Double, Double)
glyphAdvance :: (Double, Double),
forall a. FTFC_Glyph a -> FTFC_Subpixel
glyphSubpixel :: FTFC_Subpixel,
forall a. FTFC_Glyph a -> FT_Glyph_Metrics
glyphMetrics :: FT_Glyph_Metrics
}
glyphForIndex :: FTFC_Instance -> Word32 -> FTFC_Subpixel ->
(FT_Bitmap -> IO a) -> IO (FTFC_Glyph a)
glyphForIndex :: forall a.
FTFC_Instance
-> FT_UInt
-> FTFC_Subpixel
-> (FT_Bitmap -> IO a)
-> IO (FTFC_Glyph a)
glyphForIndex FTFC_Instance
font FT_UInt
index FTFC_Subpixel
subpixel FT_Bitmap -> IO a
cb = do
FT_Face -> FT_UInt -> FT_Int32 -> IO ()
ft_Load_Glyph (FTFC_Instance -> FT_Face
fontFace FTFC_Instance
font) FT_UInt
index (forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ FTFC_Instance -> Int
fontLoadFlags FTFC_Instance
font)
FT_FaceRec
face' <- forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ FTFC_Instance -> FT_Face
fontFace FTFC_Instance
font
FT_SizeRec
size' <- forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ FT_FaceRec -> FT_Size
frSize FT_FaceRec
face'
let strength :: FT_Fixed
strength = forall a b. (Integral a, Num b) => a -> b
fromIntegral (FT_FaceRec -> FT_UShort
frUnits_per_EM FT_FaceRec
face')forall a. Num a => a -> a -> a
*FT_Size_Metrics -> FT_Fixed
smY_scale (FT_SizeRec -> FT_Size_Metrics
srMetrics FT_SizeRec
size')forall a. Integral a => a -> a -> a
`div`FT_Fixed
24
FT_GlyphSlotRec
glyph' <- forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ FT_FaceRec -> FT_GlyphSlot
frGlyph FT_FaceRec
face'
FT_GlyphSlotRec
glyph1' <- case FT_GlyphSlotRec -> FT_UInt
gsrFormat FT_GlyphSlotRec
glyph' of
FT_UInt
FT_GLYPH_FORMAT_OUTLINE | FTFC_Instance -> Bool
fontEmbolden FTFC_Instance
font -> do
FT_Outline
outline <- forall a b. Storable a => a -> (Ptr a -> IO b) -> IO a
withPtr (FT_GlyphSlotRec -> FT_Outline
gsrOutline FT_GlyphSlotRec
glyph') forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr FT_Outline -> FT_Fixed -> IO ()
ft_Outline_Embolden FT_Fixed
strength
forall (m :: * -> *) a. Monad m => a -> m a
return FT_GlyphSlotRec
glyph' { gsrOutline :: FT_Outline
gsrOutline = FT_Outline
outline }
FT_UInt
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return FT_GlyphSlotRec
glyph'
let render_flags :: Int
render_flags = case FTFC_Subpixel
subpixel of {
FTFC_Subpixel
_ | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ FTFC_Instance -> Bool
fontAntialias FTFC_Instance
font -> FTFC_Instance -> Int
fontRenderFlags FTFC_Instance
font;
FTFC_Subpixel
SubpixelNone -> FTFC_Instance -> Int
fontRenderFlags FTFC_Instance
font;
FTFC_Subpixel
SubpixelHorizontalRGB -> Int
ft_RENDER_MODE_LCD;
FTFC_Subpixel
SubpixelHorizontalBGR -> Int
ft_RENDER_MODE_LCD;
FTFC_Subpixel
SubpixelVerticalRGB -> Int
ft_RENDER_MODE_LCD_V;
FTFC_Subpixel
SubpixelVerticalBGR -> Int
ft_RENDER_MODE_LCD_V;
FTFC_Subpixel
SubpixelDefault -> FTFC_Instance -> Int
fontRenderFlagsSubpixel FTFC_Instance
font}
let bgr :: Bool
bgr = case FTFC_Subpixel
subpixel of {
FTFC_Subpixel
_ | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ FTFC_Instance -> Bool
fontAntialias FTFC_Instance
font -> Bool
False;
FTFC_Subpixel
SubpixelNone -> Bool
False;
FTFC_Subpixel
SubpixelHorizontalRGB -> Bool
False;
FTFC_Subpixel
SubpixelHorizontalBGR -> Bool
True;
FTFC_Subpixel
SubpixelVerticalRGB -> Bool
False;
FTFC_Subpixel
SubpixelVerticalBGR -> Bool
True;
FTFC_Subpixel
SubpixelDefault -> FTFC_Instance -> Bool
fontBGR FTFC_Instance
font}
Bool
can_set_lcd_filter <- forall a. IO a -> IO Bool
isSuccess forall a b. (a -> b) -> a -> b
$ FT_Library -> FT_UInt -> IO ()
ft_Library_SetLcdFilter (FT_GlyphSlotRec -> FT_Library
gsrLibrary FT_GlyphSlotRec
glyph1') FT_UInt
0
let set_lcd_filter :: IO ()
set_lcd_filter = FT_Library -> FT_UInt -> IO ()
ft_Library_SetLcdFilter (FT_GlyphSlotRec -> FT_Library
gsrLibrary FT_GlyphSlotRec
glyph1') forall a b. (a -> b) -> a -> b
$ FTFC_Instance -> FT_UInt
fontLCDFilter FTFC_Instance
font
case Int
render_flags of {
Int
FT_RENDER_MODE_LCD | Bool
can_set_lcd_filter -> IO ()
set_lcd_filter;
Int
FT_RENDER_MODE_LCD_V | Bool
can_set_lcd_filter -> IO ()
set_lcd_filter;
Int
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()}
FT_GlyphSlotRec
glyph2' <- case FT_GlyphSlotRec -> FT_UInt
gsrFormat FT_GlyphSlotRec
glyph1' of {
FT_UInt
FT_GLYPH_FORMAT_BITMAP -> forall (m :: * -> *) a. Monad m => a -> m a
return FT_GlyphSlotRec
glyph1';
FT_UInt
_ -> forall a b. Storable a => a -> (Ptr a -> IO b) -> IO a
withPtr FT_GlyphSlotRec
glyph1' forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip FT_GlyphSlot -> FT_UInt -> IO ()
ft_Render_Glyph forall a b. (a -> b) -> a -> b
$ forall a. Enum a => Int -> a
toEnum Int
render_flags}
case FT_GlyphSlotRec -> FT_UInt
gsrFormat FT_GlyphSlotRec
glyph2' of {
FT_UInt
FT_GLYPH_FORMAT_BITMAP -> forall (m :: * -> *) a. Monad m => a -> m a
return ();
FT_UInt
_ -> forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ FilePath -> FT_Int32 -> FtError
FtError FilePath
"glyphForIndex" FT_Int32
2
}
a
img <- FT_Bitmap -> IO a
cb forall a b. (a -> b) -> a -> b
$ FT_GlyphSlotRec -> FT_Bitmap
gsrBitmap FT_GlyphSlotRec
glyph2'
forall (m :: * -> *) a. Monad m => a -> m a
return Glyph {
glyphFontName :: Maybe FilePath
glyphFontName = FTFC_Instance -> Maybe FilePath
fontName FTFC_Instance
font, glyphImage :: a
glyphImage = a
img,
glyphAdvance :: (Double, Double)
glyphAdvance = (forall a b. (Integral a, Num b) => a -> b
fromIntegral (FT_Vector -> FT_Fixed
vX forall a b. (a -> b) -> a -> b
$ FT_GlyphSlotRec -> FT_Vector
gsrAdvance FT_GlyphSlotRec
glyph2') forall a. Fractional a => a -> a -> a
/ Double
64 forall a. Num a => a -> a -> a
*
if FTFC_Instance -> Bool
fontPixelFixupEstimated FTFC_Instance
font then FTFC_Instance -> Double
fontPixelSizeFixup FTFC_Instance
font else Double
1,
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FT_Vector -> FT_Fixed
vY forall a b. (a -> b) -> a -> b
$ FT_GlyphSlotRec -> FT_Vector
gsrAdvance FT_GlyphSlotRec
glyph2') forall a. Fractional a => a -> a -> a
/ Double
64 forall a. Num a => a -> a -> a
*
if FTFC_Instance -> Bool
fontPixelFixupEstimated FTFC_Instance
font then FTFC_Instance -> Double
fontPixelSizeFixup FTFC_Instance
font else Double
1),
glyphSubpixel :: FTFC_Subpixel
glyphSubpixel = FTFC_Subpixel
subpixel,
glyphMetrics :: FT_Glyph_Metrics
glyphMetrics = FT_GlyphSlotRec -> FT_Glyph_Metrics
gsrMetrics FT_GlyphSlotRec
glyph2'
}
bmpAndMetricsForIndex ::
FTFC_Instance -> FTFC_Subpixel -> Word32 -> IO (FT_Bitmap, FT_Glyph_Metrics)
bmpAndMetricsForIndex :: FTFC_Instance
-> FTFC_Subpixel -> FT_UInt -> IO (FT_Bitmap, FT_Glyph_Metrics)
bmpAndMetricsForIndex FTFC_Instance
inst FTFC_Subpixel
subpixel FT_UInt
index = do
FTFC_Glyph FT_Bitmap
glyph <- forall a.
FTFC_Instance
-> FT_UInt
-> FTFC_Subpixel
-> (FT_Bitmap -> IO a)
-> IO (FTFC_Glyph a)
glyphForIndex FTFC_Instance
inst FT_UInt
index FTFC_Subpixel
subpixel forall (f :: * -> *) a. Applicative f => a -> f a
pure
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. FTFC_Glyph a -> a
glyphImage FTFC_Glyph FT_Bitmap
glyph, forall a. FTFC_Glyph a -> FT_Glyph_Metrics
glyphMetrics FTFC_Glyph FT_Bitmap
glyph)
withPtr :: Storable a => a -> (Ptr a -> IO b) -> IO a
withPtr :: forall a b. Storable a => a -> (Ptr a -> IO b) -> IO a
withPtr a
a Ptr a -> IO b
cb = forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr a
a' -> do
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
a' a
a
Ptr a -> IO b
cb Ptr a
a'
forall a. Storable a => Ptr a -> IO a
peek Ptr a
a'
isSuccess :: IO a -> IO Bool
isSuccess :: forall a. IO a -> IO Bool
isSuccess IO a
cb = do
IO a
cb
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(FtError FilePath
_ FT_Int32
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
m22toFt :: M22 Double -> FT_Matrix
m22toFt :: M22 Double -> FT_Matrix
m22toFt (V2 (V2 Double
xx Double
xy) (V2 Double
yx Double
yy)) = FT_Matrix {
mXx :: FT_Fixed
mXx = Double -> FT_Fixed
c Double
xx forall a. Num a => a -> a -> a
* FT_Fixed
0x10000, mXy :: FT_Fixed
mXy = Double -> FT_Fixed
c Double
xy forall a. Num a => a -> a -> a
* FT_Fixed
0x10000,
mYx :: FT_Fixed
mYx = Double -> FT_Fixed
c Double
yx forall a. Num a => a -> a -> a
* FT_Fixed
0x10000, mYy :: FT_Fixed
mYy = Double -> FT_Fixed
c Double
yy forall a. Num a => a -> a -> a
* FT_Fixed
0x10000
} where c :: Double -> FT_Fixed
c = forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum
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 :: Int
ft_LOAD_DEFAULT = Int
0
ft_LOAD_NO_SCALE :: Int
ft_LOAD_NO_SCALE = Int
1
ft_LOAD_NO_HINTING :: Int
ft_LOAD_NO_HINTING = Int
2
ft_LOAD_RENDER :: Int
ft_LOAD_RENDER = Int
4
ft_LOAD_NO_BITMAP :: Int
ft_LOAD_NO_BITMAP = Int
8
ft_LOAD_VERTICAL_LAYOUT :: Int
ft_LOAD_VERTICAL_LAYOUT = Int
16
ft_LOAD_FORCE_AUTOHINT :: Int
ft_LOAD_FORCE_AUTOHINT = Int
32
ft_LOAD_CROP_BITMAP :: Int
ft_LOAD_CROP_BITMAP = Int
64
ft_LOAD_PEDANTIC :: Int
ft_LOAD_PEDANTIC = Int
128
ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH :: Int
ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH = Int
512
ft_LOAD_NO_RECURSE :: Int
ft_LOAD_NO_RECURSE = Int
1024
ft_LOAD_IGNORE_TRANSFORM :: Int
ft_LOAD_IGNORE_TRANSFORM = Int
2048
ft_LOAD_MONOCHROME :: Int
ft_LOAD_MONOCHROME = Int
4096
ft_LOAD_LINEAR_DESIGN :: Int
ft_LOAD_LINEAR_DESIGN = Int
8192
ft_LOAD_NO_AUTOHINT :: Int
ft_LOAD_NO_AUTOHINT = Int
32768
ft_LOAD_COLOR :: Int
ft_LOAD_COLOR = Int
1048576
ft_LOAD_COMPUTE_METRICS :: Int
ft_LOAD_COMPUTE_METRICS = Int
2097152
ft_LOAD_BITMAP_METRICS_ONLY :: Int
ft_LOAD_BITMAP_METRICS_ONLY = Int
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 :: Int
ft_LOAD_TARGET_NORMAL = Int
0
ft_LOAD_TARGET_LIGHT :: Int
ft_LOAD_TARGET_LIGHT = Int
65536
ft_LOAD_TARGET_MONO :: Int
ft_LOAD_TARGET_MONO = Int
131072
ft_LOAD_TARGET_LCD :: Int
ft_LOAD_TARGET_LCD = Int
196608
ft_LOAD_TARGET_LCD_V :: Int
ft_LOAD_TARGET_LCD_V = Int
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 :: Int
ft_RENDER_MODE_NORMAL = Int
0
ft_RENDER_MODE_LIGHT :: Int
ft_RENDER_MODE_LIGHT = Int
1
ft_RENDER_MODE_MONO :: Int
ft_RENDER_MODE_MONO = Int
2
ft_RENDER_MODE_LCD :: Int
ft_RENDER_MODE_LCD = Int
3
ft_RENDER_MODE_LCD_V :: Int
ft_RENDER_MODE_LCD_V = Int
4