From d0b230b84ce2cc02133c24f51173f95cd41ddb6e Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 3 May 2024 17:22:47 +1200 Subject: [PATCH] Implement Stylist traits for FontConfig patterns! --- fontconfig-pure.cabal | 2 +- lib/Graphics/Text/Font/Choose/Pattern.hs | 104 ++++++++++++++--------- 2 files changed, 63 insertions(+), 43 deletions(-) diff --git a/fontconfig-pure.cabal b/fontconfig-pure.cabal index 987813c..0de9909 100644 --- a/fontconfig-pure.cabal +++ b/fontconfig-pure.cabal @@ -86,7 +86,7 @@ library build-depends: base >=4.12 && <5, containers >=0.1 && <1, css-syntax, freetype2 >=0.2 && <0.3, hashable >=1.3 && <2, linear >=1.0.1 && <2, scientific, stylist-traits >=0.1.1 && <1, text, msgpack >= 1.0 && <2, - vector >= 0.13 && <1, bytestring + vector >= 0.13 && <1, bytestring, stylist-traits, css-syntax -- Directories containing source files. hs-source-dirs: lib diff --git a/lib/Graphics/Text/Font/Choose/Pattern.hs b/lib/Graphics/Text/Font/Choose/Pattern.hs index 31c4c24..4328569 100644 --- a/lib/Graphics/Text/Font/Choose/Pattern.hs +++ b/lib/Graphics/Text/Font/Choose/Pattern.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric, CApiFFI #-} +{-# LANGUAGE OverloadedStrings #-} module Graphics.Text.Font.Choose.Pattern where import Data.Map as M @@ -14,8 +15,16 @@ import Graphics.Text.Font.Choose.Internal.FFI (withMessage, fromMessage0, withCS import Graphics.Text.Font.Choose.Value import Graphics.Text.Font.Choose.ObjectSet import Graphics.Text.Font.Choose.Result +import Graphics.Text.Font.Choose.Weight -type Pattern = Map String [(Binding, Value)] +import Stylist (StyleSheet(..), PropertyParser(..)) +import Stylist.Parse (parseProperties) +import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..), serialize) +import Data.Text (Text, unpack) +import Data.Scientific (toRealFloat) +import Data.List (intercalate) + +type Pattern = Map Text [(Binding, Value)] data Pattern' = Pattern' { unPattern :: Pattern } data Binding = Strong | Weak | Same deriving (Eq, Ord, Enum, Read, Show, Generic) @@ -30,6 +39,11 @@ instance MessagePack Binding where toObject Weak = ObjectBool False toObject Same = ObjectNil +setValue :: ToValue v => Text -> Binding -> v -> Pattern -> Pattern +setValue key strength v self = setValues key strength [v] self +setValues :: ToValue v => Text -> Binding -> [v] -> Pattern -> Pattern +setValues key strength vs self = M.insert key [(strength, toValue v) | v <- vs] self + equalSubset :: Pattern -> Pattern -> ObjectSet -> Bool equalSubset a b os = case withMessage fcPatternEqualSubset [toObject a, toObject b, toObject os] of 0 -> False @@ -62,7 +76,7 @@ foreign import capi "fontconfig-wrap.h" fcNameFormat :: CString -> Int -> CStrin --- CSS ------ -{-parseFontFamily :: [Token] -> ([String], Bool, [Token]) +parseFontFamily :: [Token] -> ([String], Bool, [Token]) parseFontFamily (String font:Comma:tail) = let (fonts, b, tail') = parseFontFamily tail in (unpack font:fonts, b, tail') parseFontFamily (Ident font:Comma:tail) = let (fonts, b, tail') = parseFontFamily tail @@ -132,59 +146,65 @@ nv2double (NVNumber x) = toRealFloat x sets a b c d = Just $ setValues a b c d set a b c d = Just $ setValue a b c d seti a b c d = Just $ setValue a b (c :: Int) d -unset' a b = Just $ unset a b +unset' a b = Just $ M.delete a b -getSize pat | ValueDouble x <- getValue "size" pat = x +getSize pat | Just [(_, ValueDouble x)] <- M.lookup "size" pat = x | otherwise = 10 -instance PropertyParser Pattern where - temp = [] +instance PropertyParser Pattern' where + temp = Pattern' M.empty - longhand _ self "font-family" toks - | (fonts, True, []) <- parseFontFamily toks = sets "family" Strong fonts self + longhand _ (Pattern' self) "font-family" toks + | (fonts, True, []) <- parseFontFamily toks = Pattern' <$> sets "family" Strong fonts self -- font-size: initial should be configurable! - longhand super self "font-size" [Dimension _ x unit] + longhand (Pattern' super) (Pattern' self) "font-size" [Dimension _ x unit] | let y = parseLength (getSize super) x unit, not $ isNaN y = - set "size" Strong y self + Pattern' <$> set "size" Strong y self longhand super self "font-size" [Percentage x y] = longhand super self "font-size" [Dimension x y "%"] - longhand _ self "font-style" [Ident "initial"] = seti "slant" Strong 0 self - longhand _ self "font-style" [Ident "normal"] = seti "slant" Strong 0 self - longhand _ self "font-style" [Ident "italic"] = seti "slant" Strong 100 self - longhand _ self "font-style" [Ident "oblique"] = seti "slant" Strong 110 self + longhand _ (Pattern' self) "font-style" [Ident "initial"] = Pattern' <$> seti "slant" Strong 0 self + longhand _ (Pattern' self) "font-style" [Ident "normal"] = Pattern' <$> seti "slant" Strong 0 self + longhand _ (Pattern' self) "font-style" [Ident "italic"] = Pattern' <$> seti "slant" Strong 100 self + longhand _ (Pattern' self) "font-style" [Ident "oblique"] = Pattern' <$> seti "slant" Strong 110 self -- Conversion between CSS scale & FontConfig scale is non-trivial, use lookuptable. - longhand _ self "font-weight" [tok] - | Just x <- parseFontWeight tok = seti "weight" Strong x self + -- FIXME: Use Graphics.Text.Font.Choose.Weight! + longhand _ (Pattern' self) "font-weight" [tok] + | Just x <- parseFontWeight tok = Pattern' <$> seti "weight" Strong x self longhand super self "font-weight" [Number _ (NVInteger x)] | x > 920 = longhand super self "font-weight" [Number "" $ NVInteger 950] | otherwise = longhand super self "font-weight" [Number "" $ NVInteger $ (x `div` 100) * 100] - longhand _ self "font-weight" [Ident "lighter"] - | ValueInt x <- getValue "weight" self, x > 200 = seti "weight" Strong 200 self + longhand _ (Pattern' self) "font-weight" [Ident "lighter"] + | Just ((_, ValueInt x):_) <- M.lookup "weight" self, x > 200 = + Pattern' <$> seti "weight" Strong 200 self -- minus 100 adhears to the CSS standard awefully well in this new scale. - | ValueInt x <- getValue "weight" self = seti "weight" Strong (max (x - 100) 0) self - | otherwise = seti "weight" Strong 0 self - longhand _ self "font-weight" [Ident "bolder"] - | ValueInt x <- getValue "weight" self, x <= 65 = seti "weight" Strong 80 self - | ValueInt x <- getValue "weight" self, x <= 150 = seti "weight" Strong 200 self - | ValueInt x <- getValue "weight" self, x < 210 = seti "weight" Strong 210 self - | ValueInt _ <- getValue "weight" self = Just self -- As bold as it goes... - | otherwise = seti "weight" Strong 200 self - - longhand _ self "font-feature-settings" [Ident k] - | k `elem` ["initial", "normal"] = unset' "fontfeatures" self - longhand _ self "font-feature-settings" toks - | (features, True, []) <- parseFontFeatures toks = - set "fontfeatures" Strong (intercalate "," $ map fst features) self - - longhand _ self "font-variation-settings" [Ident k] - | k `elem` ["initial", "normal"] = unset' "variable" self - longhand _ self "font-variation-settings" toks - | (_, True, []) <- parseFontVars toks = set "variable" Strong True self - - longhand _ s "font-stretch" [tok] - | Just x <- parseFontStretch tok = seti "width" Strong x s - - longhand _ _ _ _ = Nothing -} + | Just ((_, ValueInt x):_) <- M.lookup "weight" self = + Pattern' <$> seti "weight" Strong (max (x - 100) 0) self + | otherwise = Pattern' <$> seti "weight" Strong 0 self + longhand _ self'@(Pattern' self) "font-weight" [Ident "bolder"] + | Just ((_, ValueInt x):_) <- M.lookup "weight" self, x <= 65 = + Pattern' <$> seti "weight" Strong 80 self + | Just ((_, ValueInt x):_) <- M.lookup "weight" self, x <= 150 = + Pattern' <$> seti "weight" Strong 200 self + | Just ((_, ValueInt x):_) <- M.lookup "weight" self, x < 210 = + Pattern' <$> seti "weight" Strong 210 self + | Just ((_, ValueInt _):_) <- M.lookup "weight" self = Just self' -- As bold as it goes... + | otherwise = Pattern' <$> seti "weight" Strong 200 self + + longhand _ (Pattern' self) "font-feature-settings" [Ident k] + | k `elem` ["initial", "normal"] = Pattern' <$> unset' "fontfeatures" self + longhand _ (Pattern' self) "font-feature-settings" toks + | (features, True, []) <- parseFontFeatures toks = Pattern' <$> + set "fontfeatures" Strong (intercalate "," $ Prelude.map fst features) self + + longhand _ (Pattern' self) "font-variation-settings" [Ident k] + | k `elem` ["initial", "normal"] = Pattern' <$> unset' "variable" self + longhand _ (Pattern' self) "font-variation-settings" toks + | (_, True, []) <- parseFontVars toks = Pattern' <$> set "variable" Strong True self + + longhand _ (Pattern' s) "font-stretch" [tok] + | Just x <- parseFontStretch tok = Pattern' <$> seti "width" Strong x s + + longhand _ _ _ _ = Nothing -- 2.30.2