M Graphics/Layout.hs => Graphics/Layout.hs +1 -1
@@ 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)
A Graphics/Layout/CSS/Font.hs => Graphics/Layout/CSS/Font.hs +210 -0
@@ 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"
M Graphics/Layout/CSS/Internal.hs => Graphics/Layout/CSS/Internal.hs +0 -188
@@ 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"
M Graphics/Layout/Inline.hs => Graphics/Layout/Inline.hs +1 -1
@@ 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
M Graphics/Layout/Inline/CSS.hs => Graphics/Layout/Inline/CSS.hs +1 -1
@@ 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
M cattrap.cabal => cattrap.cabal +3 -2
@@ 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: