{-# LANGUAGE OverloadedStrings #-}
module Graphics.Layout.CSS.Internal 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 Data.Text.Glyphize as HB
import Graphics.Text.Font.Choose (Pattern(..), Value(..), normalizePattern,
getValue', getValue0, setValue, Binding(..),
configSubstitute', defaultSubstitute,
fontMatch', MatchKind(..))
import qualified Data.ByteString as B
import System.IO.Unsafe (unsafePerformIO)
type Unitted = (Double, Txt.Text)
auto :: Unitted
auto = (0,"auto")
parseLength :: [Token] -> Maybe Unitted
parseLength [Percentage _ x] = Just (n2f x,"%")
parseLength [Dimension _ x unit]
| n2f x == 0 && unit == "" = Just (0,"px")
| unit `elem` units = Just (n2f x,unit)
parseLength [Ident "auto"] = Just (0,"auto")
parseLength [Ident "initial"] = Just (0,"auto")
parseLength _ = Nothing
parseLength' [Ident "min-content"] = Just (0,"min-content")
parseLength' [Ident "max-content"] = Just (0,"max-content")
parseLength' toks = parseLength toks
units = Txt.words "cap ch em ex ic lh rem rlh vh vw vmax vmin px cm mm Q in pc pt %"
n2f (NVInteger x) = realToFrac x
n2f (NVNumber x) = toRealFloat x
finalizeLength :: Unitted -> Font' -> Length
finalizeLength (x,"cap") f = Pixels $ x*fontHeight f 'A'
finalizeLength (x,"ch") f = Pixels $ x*fontAdvance f '0'
finalizeLength (x,"em") f = Pixels $ x*fontSize f
finalizeLength (x,"") f = Pixels $ x*fontSize f -- For line-height.
finalizeLength (x,"ex") f = Pixels $ x*fontHeight f 'x'
finalizeLength (x,"ic") f = Pixels $ x*fontHeight f '水' -- CJK water ideograph
finalizeLength (x,"lh") f = Pixels $ x*lineheight f
finalizeLength (x,"rem") f = Pixels $ x*rootEm f
finalizeLength (x,"rlh") f = Pixels $ x*rlh f
finalizeLength (x,"vh") f = Pixels $ x*vh f
finalizeLength (x,"vw") f = Pixels $ x*vw f
finalizeLength (x,"vmax") f = Percent $ x*vmax f
finalizeLength (x,"vmin") f = Percent $ x*vmin f
finalizeLength (x,"px") f = Pixels $ x*scale f
finalizeLength (x,"cm") f = Pixels $ x*scale f*96/2.54
finalizeLength (x,"in") f = Pixels $ x*96*scale f
finalizeLength (x,"mm") f | Pixels x' <- finalizeLength (x,"cm") f = Pixels $ x'/10
finalizeLength (x,"Q") f | Pixels x' <- finalizeLength (x,"cm") f = Pixels $ x'/40
finalizeLength (x,"pc") f | Pixels x' <- finalizeLength (x,"in") f = Pixels $ x'/6
finalizeLength (x,"pt") f | Pixels x' <- finalizeLength (x,"in") f = Pixels $ x'/72
finalizeLength (x,"%") _ = Percent $ x/100
finalizeLength (_,"auto") _ = Auto
finalizeLength (_,"min-content") _ = Min
finalizeLength (_,"max-content") _ = Preferred
finalizeLength (x, " ") _ = Pixels x -- Internal constant value...
finalizeLength (_,unit) _ = trace ("Invalid unit " ++ Txt.unpack unit) $ Pixels 0
px2pt f x = x / scale f / 96 * 72
data Font' = Font' {
hbFont :: Font,
pattern :: Pattern,
fontHeight :: Char -> Double,
fontAdvance :: Char -> Double,
fontSize :: Double,
rootEm :: Double,
lineheight :: Double,
rlh :: Double,
vh :: Double,
vw :: Double,
vmax :: Double,
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 | Nothing <- lookup "file" pat =
let pat' = setValue "file" "/usr/share/fonts/truetype/dejavu/DejaVuSans.ttf" pat
in pattern2hbfont pat' scale variations
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
pat' | 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 = fromMaybe (pattern parent) $ fontMatch' $ defaultSubstitute $
flip configSubstitute' MatchPattern pat'
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"