From bd870636d6af38a9f04e6fd708eeb4df31ccb2e7 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 25 Jan 2023 11:48:15 +1300 Subject: [PATCH] Fix font-feature support, simplify API, & add type signatures. --- src/Typograffiti.hs | 6 ++-- src/Typograffiti/Store.hs | 27 +++++++++------- src/Typograffiti/Text.hs | 67 +++++++++++++++++++++++++-------------- 3 files changed, 61 insertions(+), 39 deletions(-) diff --git a/src/Typograffiti.hs b/src/Typograffiti.hs index e4f2566..0143abf 100644 --- a/src/Typograffiti.hs +++ b/src/Typograffiti.hs @@ -12,10 +12,8 @@ module Typograffiti( makeDrawGlyphs, AllocatedRendering(..), Layout(..), SpatialTransform(..), TextTransform(..), move, scale, rotate, color, alpha, withFontStore, newFontStore, FontStore(..), Font(..), - makeDrawTextIndentedCached, makeDrawTextCached, - makeDrawAsciiIndentedCached, makeDrawAsciiCached, - makeDrawTextIndented, makeDrawTextIndented', makeDrawText, makeDrawText', - makeDrawAsciiIndented, makeDrawAsciiIndented', makeDrawAscii, makeDrawAscii' + SampleText (..), defaultSample, addSampleFeature, + makeDrawTextCached, makeDrawText ) where import Typograffiti.Atlas diff --git a/src/Typograffiti/Store.hs b/src/Typograffiti/Store.hs index a946c21..c7ca2de 100644 --- a/src/Typograffiti/Store.hs +++ b/src/Typograffiti/Store.hs @@ -31,11 +31,12 @@ import Data.Text.Glyphize (defaultBuffer, Buffer(..), shape, GlyphInfo(..), GlyphPos(..)) import qualified Data.Text.Glyphize as HB import Data.Text.Lazy (Text, pack) +import qualified Data.Text.Lazy as Txt import FreeType.Core.Base import Typograffiti.Atlas import Typograffiti.Cache -import Typograffiti.Text (GlyphSize(..), drawLinesWrapper) +import Typograffiti.Text (GlyphSize(..), drawLinesWrapper, SampleText(..)) data FontStore n = FontStore { fontMap :: TMVar (Map (FilePath, GlyphSize, Int) Font), @@ -48,14 +49,20 @@ data Font = Font { atlases :: TMVar [(IS.IntSet, Atlas)] } -makeDrawTextIndentedCached store filepath index fontsize features sampletext indent = do +makeDrawTextCached :: (MonadIO m, MonadFail m, MonadError TypograffitiError m, + MonadIO n, MonadFail n, MonadError TypograffitiError n) => + FontStore n -> FilePath -> Int -> GlyphSize -> SampleText -> + m (String -> [HB.Feature] -> n (AllocatedRendering [TextTransform])) +makeDrawTextCached store filepath index fontsize SampleText {..} = do s <- liftIO $ atomically $ readTMVar $ fontMap store font <- case M.lookup (filepath, fontsize, index) s of Nothing -> allocFont store filepath index fontsize Just font -> return font let glyphs = map (codepoint . fst) $ - shape (harfbuzz font) defaultBuffer { text = sampletext } features + shape (harfbuzz font) defaultBuffer { + text = Txt.replicate (toEnum $ succ $ length sampleFeatures) sampleText + } sampleFeatures let glyphset = IS.fromList $ map fromEnum glyphs a <- liftIO $ atomically $ readTMVar $ atlases font @@ -63,10 +70,11 @@ makeDrawTextIndentedCached store filepath index fontsize features sampletext ind (atlas:_) -> return atlas _ -> allocAtlas' (atlases font) (freetype font) glyphset - return $ drawLinesWrapper indent $ \string -> drawGlyphs store atlas $ - shape (harfbuzz font) defaultBuffer { text = pack string } features + return $ drawLinesWrapper tabwidth $ \string features -> drawGlyphs store atlas $ + shape (harfbuzz font) defaultBuffer { text = pack string } [] -allocFont FontStore {..} filepath index fontsize = do +allocFont :: (MonadIO m) => FontStore n -> FilePath -> Int -> GlyphSize -> m Font +allocFont FontStore {..} filepath index fontsize = liftIO $ do font <- ft_New_Face lib filepath $ toEnum index case fontsize of PixelSize w h -> ft_Set_Pixel_Sizes font (toEnum $ x2 w) (toEnum $ x2 h) @@ -80,7 +88,7 @@ allocFont FontStore {..} filepath index fontsize = do atlases <- liftIO $ atomically $ newTMVar [] let ret = Font font' font atlases - liftIO $ atomically $ do + atomically $ do map <- takeTMVar fontMap putTMVar fontMap $ M.insert (filepath, fontsize, index) ret map return ret @@ -109,8 +117,3 @@ newFontStore lib = do store <- liftIO $ atomically $ newTMVar M.empty return $ FontStore store drawGlyphs lib - -makeDrawTextCached a b c d e f = makeDrawTextIndentedCached a b c d e f 4 -makeDrawAsciiIndentedCached a b c d e f = - makeDrawTextIndentedCached a b c d e (pack $ map toEnum [32..126]) f -makeDrawAsciiCached a b c d e = makeDrawTextCached a b c d e $ pack $ map toEnum [32..126] diff --git a/src/Typograffiti/Text.hs b/src/Typograffiti/Text.hs index b1df764..60ff018 100644 --- a/src/Typograffiti/Text.hs +++ b/src/Typograffiti/Text.hs @@ -3,6 +3,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} -- | -- Module: Typograffiti.Monad -- Copyright: (c) 2018 Schell Scivally @@ -31,6 +32,7 @@ import Data.Text.Glyphize (defaultBuffer, Buffer(..), shape, Glyph import qualified Data.Text.Glyphize as HB import FreeType.Core.Base import Data.Text.Lazy (Text, pack) +import qualified Data.Text.Lazy as Txt import Typograffiti.Atlas import Typograffiti.Cache @@ -39,11 +41,27 @@ data GlyphSize = CharSize Float Float Int Int | PixelSize Int Int deriving (Show, Eq, Ord) -makeDrawTextIndented :: (MonadIO m, MonadFail m, MonadError TypograffitiError m, +data SampleText = SampleText { + sampleFeatures :: [HB.Feature], + sampleText :: Text, + tabwidth :: Int +} +defaultSample = SampleText [] (pack $ map toEnum [32..126]) 4 +addSampleFeature name value sample@SampleText {..} = sample { + sampleFeatures = + HB.Feature (HB.tag_from_string name) value (n*i) (n*succ i) : sampleFeatures + } + where + n = w $ fromEnum $ Txt.length sampleText + i = w $ length sampleFeatures + w :: Int -> Word + w = toEnum + +makeDrawText :: (MonadIO m, MonadFail m, MonadError TypograffitiError m, MonadIO n, MonadFail n, MonadError TypograffitiError n) => - FT_Library -> FilePath -> Int -> GlyphSize -> [HB.Feature] -> Text -> Int -> - m (String -> n (AllocatedRendering [TextTransform])) -makeDrawTextIndented lib filepath index fontsize features sampletext indent = do + FT_Library -> FilePath -> Int -> GlyphSize -> SampleText -> + m (String -> [HB.Feature] -> n (AllocatedRendering [TextTransform])) +makeDrawText lib filepath index fontsize SampleText {..} = do font <- liftIO $ ft_New_Face lib filepath $ toEnum index liftIO $ case fontsize of PixelSize w h -> ft_Set_Pixel_Sizes font (toEnum $ x2 w) (toEnum $ x2 h) @@ -54,35 +72,27 @@ makeDrawTextIndented lib filepath index fontsize features sampletext indent = do bytes <- liftIO $ B.readFile filepath let font' = HB.createFont $ HB.createFace bytes $ toEnum index let glyphs = map (codepoint . fst) $ - shape font' defaultBuffer { text = sampletext } features + shape font' defaultBuffer { + text = Txt.replicate (toEnum $ succ $ length sampleFeatures) sampleText + } sampleFeatures let glyphs' = map toEnum $ IS.toList $ IS.fromList $ map fromEnum glyphs atlas <- allocAtlas (glyphRetriever font) glyphs' liftIO $ ft_Done_Face font drawGlyphs <- makeDrawGlyphs - return $ drawLinesWrapper indent $ \string -> + return $ drawLinesWrapper tabwidth $ \string features -> drawGlyphs atlas $ shape font' defaultBuffer { text = pack string } features where x2 = (*2) -makeDrawTextIndented' a b c d e f = - ft_With_FreeType $ \ft -> runExceptT $ makeDrawTextIndented ft a b c d e f - -makeDrawText a b c d e f = makeDrawTextIndented a b c d e f 4 -makeDrawText' a b c d e = ft_With_FreeType $ \ft -> runExceptT $ makeDrawText ft a b c d e - --- Note: May glitch upon ligatures. -makeDrawAsciiIndented a b c d e f = - makeDrawTextIndented a b c d e (pack $ map toEnum [32..126]) f -makeDrawAsciiIndented' a b c d e = - ft_With_FreeType $ \ft -> runExceptT $ makeDrawAsciiIndented ft a b c d e -makeDrawAscii a b c d e = makeDrawText a b c d e $ pack $ map toEnum [32..126] -makeDrawAscii' a b c d = ft_With_FreeType $ \ft -> runExceptT $ makeDrawAscii ft a b c d +makeDrawText' a b c d = + ft_With_FreeType $ \ft -> runExceptT $ makeDrawText ft a b c d drawLinesWrapper :: (MonadIO m, MonadFail m) => - Int -> (String -> m (AllocatedRendering [TextTransform])) -> - String -> m (AllocatedRendering [TextTransform]) -drawLinesWrapper indent cb string = do - renderers <- mapM cb $ map processLine $ lines string + Int -> (String -> [HB.Feature] -> m (AllocatedRendering [TextTransform])) -> + String -> [HB.Feature] -> m (AllocatedRendering [TextTransform]) +drawLinesWrapper indent cb string features = do + let features' = splitFeatures 0 features $ lines string + renderers <- mapM (uncurry cb) $ flip zip features' $ map processLine $ lines string let drawLine ts wsz y renderer = do arDraw renderer (move 0 y:ts) wsz let V2 _ height = arSize renderer @@ -101,6 +111,17 @@ drawLinesWrapper indent cb string = do arSize = size } where + splitFeatures _ [] _ = [] + splitFeatures _ _ [] = [] + splitFeatures offset features' (line:lines') = let n = length line + in [feat { + HB.featStart = max 0 (start - offset), + HB.featEnd = min (toEnum n) (end - offset) + } + | feat@HB.Feature {HB.featStart = start, HB.featEnd = end} <- features', + fromEnum end <= n && end >= offset] : + splitFeatures (offset + toEnum n) features' lines' + processLine "" = " " -- enforce nonempty processLine cs = expandTabs 0 cs -- monospace tabshaping, good enough outside full line-layout. -- 2.30.2