From 1d62f0618dc5890364fdfce8a0277a1f0062337c Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Sat, 26 Nov 2022 22:09:28 +1300
Subject: [PATCH] Bind FontConfig 'size' to CSS 'font-size', ensure old values
 get overriden.

---
 Graphics/Text/Font/Choose/Pattern.hs | 51 ++++++++++++++++++++++------
 fontconfig-pure.cabal                |  2 +-
 2 files changed, 41 insertions(+), 12 deletions(-)

diff --git a/Graphics/Text/Font/Choose/Pattern.hs b/Graphics/Text/Font/Choose/Pattern.hs
index 7426783..586ed33 100644
--- a/Graphics/Text/Font/Choose/Pattern.hs
+++ b/Graphics/Text/Font/Choose/Pattern.hs
@@ -20,13 +20,14 @@ import Debug.Trace (trace) -- For reporting internal errors!
 import System.IO.Unsafe (unsafePerformIO)
 
 import Control.Monad (forM, join)
-import Data.Maybe (catMaybes)
+import Data.Maybe (catMaybes, fromMaybe)
 import Control.Exception (bracket)
 
 -- Imported for CSS bindings
-import Data.CSS.Syntax.Tokens (Token(..))
-import Data.Text (unpack)
+import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
+import Data.Text (unpack, Text)
 import Stylist (PropertyParser(..))
+import Data.Scientific (toRealFloat)
 
 type Pattern = [(String, [(Binding, Value)])]
 data Binding = Strong | Weak | Same deriving (Eq, Ord, Enum, Show, Generic)
@@ -36,11 +37,15 @@ instance Hashable Binding where
     hash Weak = 1
     hash Same = 2
 
-addValue :: ToValue x => String -> Binding -> x -> Pattern -> Pattern
-addValue key b value pat = normalizePattern ((key, [(b, toValue value)]):pat)
-addValues :: ToValue x => String -> Binding -> [x] -> Pattern -> Pattern
-addValues key b values pat =
-    normalizePattern ((key, [(b, toValue v) | v <- values]):pat)
+setValue :: ToValue x => String -> Binding -> x -> Pattern -> Pattern
+setValue key b value pat = (key, [(b, toValue value)]):unset key pat
+setValues :: ToValue x => String -> Binding -> [x] -> Pattern -> Pattern
+setValues key b values pat = (key, [(b, toValue v) | v <- values]):unset key pat
+getValue :: String -> Pattern -> Maybe Value
+getValue key pat | Just ((_, ret):_) <- lookup key pat = Just ret
+    | otherwise = Nothing
+
+unset key mapping = [(key', val') | (key', val') <- mapping, key' /= key]
 
 normalizePattern :: Pattern -> Pattern
 normalizePattern pat =
@@ -172,12 +177,36 @@ parseFontFamily (String font:tail) = ([unpack font], True, tail)
 parseFontFamily (Ident font:tail) = ([unpack font], True, tail)
 parseFontFamily toks = ([], False, toks) -- Invalid syntax!
 
-adds a b c d = Just $ addValues a b c d
-add a b c d = Just $ addValue a b c d
+parseLength :: Double -> NumericValue -> Text -> Double
+parseLength super length unit = convert (nv2double length) unit
+  where
+    convert = c
+    c x "pt" = x -- Unit FontConfig expects!
+    c x "pc" = x/6 `c` "in"
+    c x "in" = x/72 `c` "pt"
+    c x "Q" = x/40 `c` "cm"
+    c x "mm" = x/10 `c` "cm"
+    c x "cm" = x/2.54 `c` "in"
+    c x "px" = x/96 `c` "in" -- Conversion factor during early days of CSS, got entrenched.
+    c x "em" = x * super
+    c x "%" = x/100 `c` "em"
+    c _ _ = 0/0 -- NaN
+
+    nv2double (NVInteger x) = fromInteger x
+    nx2double (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
+
+getSize pat | Just (ValueDouble x) <- getValue "size" pat = x
+    | otherwise = 10
 
 instance PropertyParser Pattern where
     temp = []
 
     longhand _ self "font-family" toks
-        | (fonts, True, []) <- parseFontFamily toks = adds "family" Strong fonts self
+        | (fonts, True, []) <- parseFontFamily toks = sets "family" Strong fonts self
+    longhand super self "font-size" [Dimension _ x unit]
+        | let y = parseLength (getSize super) x unit, not $ isNaN y =
+            set "size" Strong y self
     longhand _ _ _ _ = Nothing
diff --git a/fontconfig-pure.cabal b/fontconfig-pure.cabal
index d005f28..1e3f5f6 100644
--- a/fontconfig-pure.cabal
+++ b/fontconfig-pure.cabal
@@ -71,7 +71,7 @@ library
   build-depends:       base >=4.12 && <4.13, containers >= 0.1 && <1,
                         linear >= 1.0.1 && <2, freetype2 >= 0.2 && < 0.3,
                         hashable >= 1.3 && <2,
-                        css-syntax, text, stylist-traits >= 0.1.1 && < 1
+                        css-syntax, text, stylist-traits >= 0.1.1 && < 1, scientific
 
   pkgconfig-depends:    fontconfig
 
-- 
2.30.2