From ddef83e36c340b2abfb8535d88bbb074964ef41e Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Thu, 23 Mar 2023 20:26:35 +1300 Subject: [PATCH] Seperate out Font API from internals. --- Graphics/Layout.hs | 2 +- Graphics/Layout/CSS/Font.hs | 210 ++++++++++++++++++++++++++++++++ Graphics/Layout/CSS/Internal.hs | 188 ---------------------------- Graphics/Layout/Inline.hs | 2 +- Graphics/Layout/Inline/CSS.hs | 2 +- cattrap.cabal | 5 +- 6 files changed, 216 insertions(+), 193 deletions(-) create mode 100644 Graphics/Layout/CSS/Font.hs diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs index dd66e9c..c91ea05 100644 --- a/Graphics/Layout.hs +++ b/Graphics/Layout.hs @@ -7,7 +7,7 @@ import Graphics.Layout.Box as B import Graphics.Layout.Grid as G import Graphics.Layout.Flow as F import Graphics.Layout.Inline as I -import Graphics.Layout.CSS.Internal (Font'(..)) +import Graphics.Layout.CSS.Font (Font'(..)) import Data.Maybe (fromMaybe) diff --git a/Graphics/Layout/CSS/Font.hs b/Graphics/Layout/CSS/Font.hs new file mode 100644 index 0000000..2881bff --- /dev/null +++ b/Graphics/Layout/CSS/Font.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Layout.CSS.Font(Font'(..), placeholderFont, hbScale, hbUnit, + pattern2hbfont, pattern2font, CSSFont(..), variations') where + +import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..), serialize) +import Stylist (PropertyParser(..)) +import qualified Data.Text as Txt +import Data.Scientific (toRealFloat) +import Debug.Trace (trace) -- For warnings. +import Data.Maybe (fromMaybe) + +import Graphics.Layout.Box +import Graphics.CSS.Internal (Font'(..)) + +import Data.Text.Glyphize as HB +import Graphics.Text.Font.Choose (Pattern(..), Value(..), normalizePattern, + getValue', getValue0, setValue, Binding(..), + configSubstitute', defaultSubstitute, + fontSort', MatchKind(..), fontRenderPrepare') +import qualified Data.ByteString as B +import System.IO.Unsafe (unsafePerformIO) + +placeholderFont = Font' undefined [] (const 0) (const 0) 0 0 0 0 0 0 0 0 1 +hbScale :: Font' -> Double +hbScale f = fontSize f*hbUnit +hbUnit = 64 :: Double + +pattern2hbfont :: Pattern -> Int -> [Variation] -> Font +pattern2hbfont pat scale variations = createFontWithOptions options face + where + bytes = unsafePerformIO $ B.readFile $ getValue0 "file" pat + face = createFace bytes $ toEnum $ fromMaybe 0 $ getValue' "index" pat + options = foldl value2opt defaultFontOptions { optionScale = Just (scale, scale) } $ + normalizePattern pat + + value2opt opts ("slant", (_, ValueInt x):_) = opts { + optionSynthSlant = Just $ realToFrac x + } + value2opt opts ("fontvariations", _:_) = opts {optionVariations = variations} + value2opt opts _ = opts + +pattern2font :: Pattern -> CSSFont -> Font' -> Font' -> Font' +pattern2font pat styles@CSSFont { cssFontSize = (x,"initial") } parent root = + pattern2font pat styles { cssFontSize = (x*fontSize root," ") } parent root +pattern2font pat styles parent root = Font' { + hbFont = font', + pattern = font, + fontHeight = height' . fontGlyphExtents font' . fontGlyph', + fontAdvance = fromIntegral . fontGlyphHAdvance font' . fontGlyph', + fontSize = fontSize', + rootEm = fontSize root, + lineheight = lineheight', + rlh = lineheight root, + + vh = vh root, + vw = vw root, + vmax = vmax root, + vmin = vmin root, + scale = scale root + } where + height' (Just x) = fromIntegral $ HB.height x + height' Nothing = fontSize' + lineheight' | snd (cssLineheight styles) == "normal", + Just extents <- fontHExtents font' = (fromIntegral $ lineGap extents)/scale' + | otherwise = lowerLength' (cssLineheight styles) parent + fontSize' = lowerLength' (cssFontSize styles) parent + lowerLength' a = lowerLength (fontSize parent) . finalizeLength a + fontGlyph' ch = fromMaybe 0 $ fontGlyph font' ch Nothing + q | Nothing <- lookup "family" pat, Just val <- lookup "family" $ pattern root = + ("family", val):setValue "size" Weak (px2pt root fontSize') pat + | otherwise = setValue "size" Weak (px2pt root fontSize') pat + font = case fontSort' (defaultSubstitute $ configSubstitute' q MatchPattern) False of + Just (font:_, _) -> fontRenderPrepare' q font + _ -> error "TODO: Set fallback font!" + font' = pattern2hbfont font (round scale') $ variations' fontSize' styles + scale' = fontSize'*hbUnit + +data CSSFont = CSSFont { + cssFontSize :: Unitted, + cssLineheight :: Unitted, + variations :: [Variation], + weightVariation :: Variation, + widthVariation :: Variation, + slantVariation :: Variation, + opticalSize :: Bool +} +variations' :: Double -> CSSFont -> [Variation] +variations' fontsize self = + (if opticalSize self then (Variation opsz (realToFrac fontsize):) else id) + (slantVariation self:widthVariation self:weightVariation self:variations self) + +fracDefault :: CSSFont -> Double -> Maybe CSSFont +fracDefault self frac = Just self { + cssFontSize = (frac,"initial") +} +instance PropertyParser CSSFont where + temp = CSSFont { + cssFontSize = (12,"pt"), + cssLineheight = (1,""), + variations = [], + weightVariation = Variation wght 400, + widthVariation = Variation wdth 100, + slantVariation = Variation ital 0, + opticalSize = True + } + inherit parent = parent + + longhand _ self "font-size" [Ident "xx-small"] = fracDefault self $ 3/5 + longhand _ self "font-size" [Ident "x-small"] = fracDefault self $ 3/4 + longhand _ self "font-size" [Ident "small"] = fracDefault self $ 8/9 + longhand _ self "font-size" [Ident "medium"] = fracDefault self 1 + longhand _ self "font-size" [Ident "initial"] = fracDefault self 1 + longhand _ self "font-size" [Ident "large"] = fracDefault self $ 6/5 + longhand _ self "font-size" [Ident "x-large"] = fracDefault self $ 3/2 + longhand _ self "font-size" [Ident "xx-large"] = fracDefault self 2 + longhand _ self "font-size" [Ident "xxx-large"] = fracDefault self 3 + longhand parent self "font-size" [Ident "larger"] = + Just self { cssFontSize = (x*1.2,unit) } + where (x,unit) = cssFontSize parent + longhand parent self "font-size" [Ident "smaller"] = + Just self { cssFontSize = (x/1.2,unit) } + where (x, unit) = cssFontSize parent + longhand _ self "font-size" toks + | Just x <- parseLength toks = Just self { cssFontSize = x } + + longhand _ self "line-height" [Ident "normal"] = Just self { cssLineheight = (0,"normal") } + longhand _ self "line-height" [Number _ x] = Just self { cssLineheight = (n2f x,"em") } + longhand _ self "line-height" toks + | Just x <- parseLength toks = Just self { cssLineheight = x } + + longhand _ self "font-variation-settings" [Ident "normal"] = Just self { variations = [] } + longhand _ self "font-variation-settings" [Ident "initial"] = Just self {variations = []} + longhand _ self "font-variation-settings" toks + | Just x <- parseVariations toks = Just self { variations = x } + + longhand _ self "font-weight" [Ident "normal"] = + Just self { weightVariation = Variation wght 400 } + longhand _ self "font-weight" [Ident "initial"] = + Just self { weightVariation = Variation wght 400 } + longhand _ self "font-weight" [Ident "bold"] = + Just self { weightVariation = Variation wght 700 } + longhand _ self "font-weight" [Number _ (NVInteger x)] | x >= 100 && x < 1000 = + Just self { weightVariation = Variation wght $ fromIntegral x } + longhand parent self "font-weight" [Ident "bolder"] + | varValue (weightVariation parent) < 400 = + Just self { weightVariation = Variation wght 400 } + | varValue (weightVariation parent) < 600 = + Just self { weightVariation = Variation wght 700 } + | otherwise = Just self { weightVariation = Variation wght 900 } + longhand parent self "font-weight" [Ident "lighter"] + | varValue (weightVariation parent) < 600 = + Just self { weightVariation = Variation wght 100 } + | varValue (weightVariation parent) < 800 = + Just self { weightVariation = Variation wght 400 } + | otherwise = Just self { weightVariation = Variation wght 700 } + + longhand _ self "font-stretch" [Ident "ultra-condensed"] = + Just self { widthVariation = Variation wdth 50 } + longhand _ self "font-stretch" [Ident "extra-condensed"] = + Just self { widthVariation = Variation wdth 62.5 } + longhand _ self "font-stretch" [Ident "condensed"] = + Just self { widthVariation = Variation wdth 75 } + longhand _ self "font-stretch" [Ident "semi-condensed"] = + Just self { widthVariation = Variation wdth 87.5 } + longhand _ self "font-stretch" [Ident k] | k `elem` ["initial", "normal"] = + Just self { widthVariation = Variation wdth 100 } + longhand _ self "font-stretch" [Ident "semi-expanded"] = + Just self { widthVariation = Variation wdth 112.5 } + longhand _ self "font-stretch" [Ident "expanded"] = + Just self { widthVariation = Variation wdth 125 } + longhand _ self "font-stretch" [Ident "extra-expanded"] = + Just self { widthVariation = Variation wdth 150 } + longhand _ self "font-stretch" [Ident "ultra-expanded"] = + Just self { widthVariation = Variation wdth 200 } + longhand _ self "font-stretch" [Percentage _ x] = + Just self { widthVariation = Variation wdth $ n2f x } + + longhand _ self "font-style" [Ident "oblique", Dimension _ x "deg"] = + Just self { slantVariation = Variation slnt $ n2f x } + longhand _ self "font-style" [Ident "oblique", Dimension _ x "grad"] = + Just self { slantVariation = Variation slnt (n2f x/400*360) } + longhand _ self "font-style" [Ident "oblique", Dimension _ x "rad"] = + Just self { slantVariation = Variation slnt (n2f x*180/pi) } + longhand _ self "font-style" [Ident "oblique", Dimension _ x "turn"] = + Just self { slantVariation = Variation slnt (n2f x*360) } + longhand _ self "font-style" [Ident "italic"] = + Just self { slantVariation = Variation ital 1 } + longhand _ self "font-style" [Ident "normal"] = + Just self { slantVariation = Variation ital 0 } + longhand _ self "font-style" [Ident "initial"] = + Just self { slantVariation = Variation ital 0 } + + longhand _ s "font-optical-sizing" [Ident "auto"] = Just s {opticalSize = True} + longhand _ s "font-optical-sizing" [Ident "initial"] = Just s {opticalSize = True} + longhand _ s "font-optical-sizing" [Ident "none"] = Just s {opticalSize = False} + + longhand _ _ _ _ = Nothing + +parseVariations (x@(String _):y@(Number _ _):Comma:toks) + | Just var <- parseVariation $ Txt.unpack $ serialize [x, y], + Just vars <- parseVariations toks = Just $ var:vars +parseVariations toks@[String _, Number _ _] + | Just var <- parseVariation $ Txt.unpack $ serialize toks = Just [var] +parseVariations _ = Nothing + +wght = tag_from_string "wght" +wdth = tag_from_string "wdth" +slnt = tag_from_string "slnt" +ital = tag_from_string "ital" +opsz = tag_from_string "opsz" diff --git a/Graphics/Layout/CSS/Internal.hs b/Graphics/Layout/CSS/Internal.hs index 5f7ba6c..6a6d059 100644 --- a/Graphics/Layout/CSS/Internal.hs +++ b/Graphics/Layout/CSS/Internal.hs @@ -83,191 +83,3 @@ data Font' = Font' { vmin :: Double, scale :: Double } -placeholderFont = Font' undefined [] (const 0) (const 0) 0 0 0 0 0 0 0 0 1 -hbScale :: Font' -> Double -hbScale f = fontSize f*hbUnit -hbUnit = 64 :: Double - -pattern2hbfont :: Pattern -> Int -> [Variation] -> Font -pattern2hbfont pat scale variations = createFontWithOptions options face - where - bytes = unsafePerformIO $ B.readFile $ getValue0 "file" pat - face = createFace bytes $ toEnum $ fromMaybe 0 $ getValue' "index" pat - options = foldl value2opt defaultFontOptions { optionScale = Just (scale, scale) } $ - normalizePattern pat - - value2opt opts ("slant", (_, ValueInt x):_) = opts { - optionSynthSlant = Just $ realToFrac x - } - value2opt opts ("fontvariations", _:_) = opts {optionVariations = variations} - value2opt opts _ = opts - -pattern2font :: Pattern -> CSSFont -> Font' -> Font' -> Font' -pattern2font pat styles@CSSFont { cssFontSize = (x,"initial") } parent root = - pattern2font pat styles { cssFontSize = (x*fontSize root," ") } parent root -pattern2font pat styles parent root = Font' { - hbFont = font', - pattern = font, - fontHeight = height' . fontGlyphExtents font' . fontGlyph', - fontAdvance = fromIntegral . fontGlyphHAdvance font' . fontGlyph', - fontSize = fontSize', - rootEm = fontSize root, - lineheight = lineheight', - rlh = lineheight root, - - vh = vh root, - vw = vw root, - vmax = vmax root, - vmin = vmin root, - scale = scale root - } where - height' (Just x) = fromIntegral $ HB.height x - height' Nothing = fontSize' - lineheight' | snd (cssLineheight styles) == "normal", - Just extents <- fontHExtents font' = (fromIntegral $ lineGap extents)/scale' - | otherwise = lowerLength' (cssLineheight styles) parent - fontSize' = lowerLength' (cssFontSize styles) parent - lowerLength' a = lowerLength (fontSize parent) . finalizeLength a - fontGlyph' ch = fromMaybe 0 $ fontGlyph font' ch Nothing - q | Nothing <- lookup "family" pat, Just val <- lookup "family" $ pattern root = - ("family", val):setValue "size" Weak (px2pt root fontSize') pat - | otherwise = setValue "size" Weak (px2pt root fontSize') pat - font = case fontSort' (defaultSubstitute $ configSubstitute' q MatchPattern) False of - Just (font:_, _) -> fontRenderPrepare' q font - _ -> error "TODO: Set fallback font!" - font' = pattern2hbfont font (round scale') $ variations' fontSize' styles - scale' = fontSize'*hbUnit - -data CSSFont = CSSFont { - cssFontSize :: Unitted, - cssLineheight :: Unitted, - variations :: [Variation], - weightVariation :: Variation, - widthVariation :: Variation, - slantVariation :: Variation, - opticalSize :: Bool -} -variations' :: Double -> CSSFont -> [Variation] -variations' fontsize self = - (if opticalSize self then (Variation opsz (realToFrac fontsize):) else id) - (slantVariation self:widthVariation self:weightVariation self:variations self) - -fracDefault :: CSSFont -> Double -> Maybe CSSFont -fracDefault self frac = Just self { - cssFontSize = (frac,"initial") -} -instance PropertyParser CSSFont where - temp = CSSFont { - cssFontSize = (12,"pt"), - cssLineheight = (1,""), - variations = [], - weightVariation = Variation wght 400, - widthVariation = Variation wdth 100, - slantVariation = Variation ital 0, - opticalSize = True - } - inherit parent = parent - - longhand _ self "font-size" [Ident "xx-small"] = fracDefault self $ 3/5 - longhand _ self "font-size" [Ident "x-small"] = fracDefault self $ 3/4 - longhand _ self "font-size" [Ident "small"] = fracDefault self $ 8/9 - longhand _ self "font-size" [Ident "medium"] = fracDefault self 1 - longhand _ self "font-size" [Ident "initial"] = fracDefault self 1 - longhand _ self "font-size" [Ident "large"] = fracDefault self $ 6/5 - longhand _ self "font-size" [Ident "x-large"] = fracDefault self $ 3/2 - longhand _ self "font-size" [Ident "xx-large"] = fracDefault self 2 - longhand _ self "font-size" [Ident "xxx-large"] = fracDefault self 3 - longhand parent self "font-size" [Ident "larger"] = - Just self { cssFontSize = (x*1.2,unit) } - where (x,unit) = cssFontSize parent - longhand parent self "font-size" [Ident "smaller"] = - Just self { cssFontSize = (x/1.2,unit) } - where (x, unit) = cssFontSize parent - longhand _ self "font-size" toks - | Just x <- parseLength toks = Just self { cssFontSize = x } - - longhand _ self "line-height" [Ident "normal"] = Just self { cssLineheight = (0,"normal") } - longhand _ self "line-height" [Number _ x] = Just self { cssLineheight = (n2f x,"em") } - longhand _ self "line-height" toks - | Just x <- parseLength toks = Just self { cssLineheight = x } - - longhand _ self "font-variation-settings" [Ident "normal"] = Just self { variations = [] } - longhand _ self "font-variation-settings" [Ident "initial"] = Just self {variations = []} - longhand _ self "font-variation-settings" toks - | Just x <- parseVariations toks = Just self { variations = x } - - longhand _ self "font-weight" [Ident "normal"] = - Just self { weightVariation = Variation wght 400 } - longhand _ self "font-weight" [Ident "initial"] = - Just self { weightVariation = Variation wght 400 } - longhand _ self "font-weight" [Ident "bold"] = - Just self { weightVariation = Variation wght 700 } - longhand _ self "font-weight" [Number _ (NVInteger x)] | x >= 100 && x < 1000 = - Just self { weightVariation = Variation wght $ fromIntegral x } - longhand parent self "font-weight" [Ident "bolder"] - | varValue (weightVariation parent) < 400 = - Just self { weightVariation = Variation wght 400 } - | varValue (weightVariation parent) < 600 = - Just self { weightVariation = Variation wght 700 } - | otherwise = Just self { weightVariation = Variation wght 900 } - longhand parent self "font-weight" [Ident "lighter"] - | varValue (weightVariation parent) < 600 = - Just self { weightVariation = Variation wght 100 } - | varValue (weightVariation parent) < 800 = - Just self { weightVariation = Variation wght 400 } - | otherwise = Just self { weightVariation = Variation wght 700 } - - longhand _ self "font-stretch" [Ident "ultra-condensed"] = - Just self { widthVariation = Variation wdth 50 } - longhand _ self "font-stretch" [Ident "extra-condensed"] = - Just self { widthVariation = Variation wdth 62.5 } - longhand _ self "font-stretch" [Ident "condensed"] = - Just self { widthVariation = Variation wdth 75 } - longhand _ self "font-stretch" [Ident "semi-condensed"] = - Just self { widthVariation = Variation wdth 87.5 } - longhand _ self "font-stretch" [Ident k] | k `elem` ["initial", "normal"] = - Just self { widthVariation = Variation wdth 100 } - longhand _ self "font-stretch" [Ident "semi-expanded"] = - Just self { widthVariation = Variation wdth 112.5 } - longhand _ self "font-stretch" [Ident "expanded"] = - Just self { widthVariation = Variation wdth 125 } - longhand _ self "font-stretch" [Ident "extra-expanded"] = - Just self { widthVariation = Variation wdth 150 } - longhand _ self "font-stretch" [Ident "ultra-expanded"] = - Just self { widthVariation = Variation wdth 200 } - longhand _ self "font-stretch" [Percentage _ x] = - Just self { widthVariation = Variation wdth $ n2f x } - - longhand _ self "font-style" [Ident "oblique", Dimension _ x "deg"] = - Just self { slantVariation = Variation slnt $ n2f x } - longhand _ self "font-style" [Ident "oblique", Dimension _ x "grad"] = - Just self { slantVariation = Variation slnt (n2f x/400*360) } - longhand _ self "font-style" [Ident "oblique", Dimension _ x "rad"] = - Just self { slantVariation = Variation slnt (n2f x*180/pi) } - longhand _ self "font-style" [Ident "oblique", Dimension _ x "turn"] = - Just self { slantVariation = Variation slnt (n2f x*360) } - longhand _ self "font-style" [Ident "italic"] = - Just self { slantVariation = Variation ital 1 } - longhand _ self "font-style" [Ident "normal"] = - Just self { slantVariation = Variation ital 0 } - longhand _ self "font-style" [Ident "initial"] = - Just self { slantVariation = Variation ital 0 } - - longhand _ s "font-optical-sizing" [Ident "auto"] = Just s {opticalSize = True} - longhand _ s "font-optical-sizing" [Ident "initial"] = Just s {opticalSize = True} - longhand _ s "font-optical-sizing" [Ident "none"] = Just s {opticalSize = False} - - longhand _ _ _ _ = Nothing - -parseVariations (x@(String _):y@(Number _ _):Comma:toks) - | Just var <- parseVariation $ Txt.unpack $ serialize [x, y], - Just vars <- parseVariations toks = Just $ var:vars -parseVariations toks@[String _, Number _ _] - | Just var <- parseVariation $ Txt.unpack $ serialize toks = Just [var] -parseVariations _ = Nothing - -wght = tag_from_string "wght" -wdth = tag_from_string "wdth" -slnt = tag_from_string "slnt" -ital = tag_from_string "ital" -opsz = tag_from_string "opsz" diff --git a/Graphics/Layout/Inline.hs b/Graphics/Layout/Inline.hs index 384befa..5e9b4b6 100644 --- a/Graphics/Layout/Inline.hs +++ b/Graphics/Layout/Inline.hs @@ -11,7 +11,7 @@ import Data.Char (isSpace) import Data.Int (Int32) import Graphics.Layout.Box (Size(..), CastDouble(..), fromDouble) -import Graphics.Layout.CSS.Internal (Font', hbScale) +import Graphics.Layout.CSS.Font (Font', hbScale) hbScale' font = (/hbScale font) . fromIntegral c font = fromDouble . hbScale' font diff --git a/Graphics/Layout/Inline/CSS.hs b/Graphics/Layout/Inline/CSS.hs index 28f6419..8e70629 100644 --- a/Graphics/Layout/Inline/CSS.hs +++ b/Graphics/Layout/Inline/CSS.hs @@ -9,7 +9,7 @@ import Data.Text.Internal (Text(..)) import Data.Text.ParagraphLayout (Span(..), SpanOptions(..), LineHeight(..), Paragraph(..), ParagraphOptions(..)) -import Graphics.Layout.CSS.Internal (Font'(..), hbScale) +import Graphics.Layout.CSS.Font (Font'(..), hbScale) import Data.Char (isSpace) data CSSInline = CSSInline Lz.Text SpanOptions diff --git a/cattrap.cabal b/cattrap.cabal index d996870..35b49f2 100644 --- a/cattrap.cabal +++ b/cattrap.cabal @@ -18,8 +18,9 @@ cabal-version: >=1.10 library exposed-modules: Graphics.Layout, Graphics.Layout.CSS, Graphics.Layout.Flow, - Graphics.Layout.Grid, Graphics.Layout.Box, Graphics.Layout.Arithmetic, - Graphics.Layout.CSS.Internal, Graphics.Layout.Grid.CSS, + Graphics.Layout.Grid, Graphics.Layout.Grid.CSS, + Graphics.Layout.Box, Graphics.Layout.Arithmetic, + Graphics.Layout.CSS.Internal, Graphics.Layout.CSS.Font, Graphics.Layout.Inline, Graphics.Layout.Inline.CSS -- other-modules: -- other-extensions: -- 2.30.2