From 5b204783d56e15ab49d018c64c27a8de67e4c460 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Fri, 25 Nov 2022 12:27:04 +1300
Subject: [PATCH] Start implementing CSS bindings with font-family, build
 underlying infrastructure.

---
 Graphics/Text/Font/Choose/Pattern.hs | 38 ++++++++++++++++++++++++++--
 Graphics/Text/Font/Choose/Value.hs   | 28 ++++++++++++++++++--
 fontconfig-pure.cabal                |  3 ++-
 3 files changed, 64 insertions(+), 5 deletions(-)

diff --git a/Graphics/Text/Font/Choose/Pattern.hs b/Graphics/Text/Font/Choose/Pattern.hs
index dd36b09..7426783 100644
--- a/Graphics/Text/Font/Choose/Pattern.hs
+++ b/Graphics/Text/Font/Choose/Pattern.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric, OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
 module Graphics.Text.Font.Choose.Pattern (Pattern(..), Binding(..), equalSubset,
     normalizePattern, filter, defaultSubstitute, nameParse, nameUnparse, format,
     Pattern_, withPattern, thawPattern, thawPattern_, patternAsPointer) where
@@ -6,7 +6,7 @@ module Graphics.Text.Font.Choose.Pattern (Pattern(..), Binding(..), equalSubset,
 import Prelude hiding (filter)
 import Data.List (nub)
 
-import Graphics.Text.Font.Choose.Value (Value, withValue, thawValue, Value_, value'Size)
+import Graphics.Text.Font.Choose.Value
 import Graphics.Text.Font.Choose.ObjectSet (ObjectSet, ObjectSet_, withObjectSet)
 import Data.Hashable (Hashable(..))
 import GHC.Generics (Generic)
@@ -23,6 +23,11 @@ import Control.Monad (forM, join)
 import Data.Maybe (catMaybes)
 import Control.Exception (bracket)
 
+-- Imported for CSS bindings
+import Data.CSS.Syntax.Tokens (Token(..))
+import Data.Text (unpack)
+import Stylist (PropertyParser(..))
+
 type Pattern = [(String, [(Binding, Value)])]
 data Binding = Strong | Weak | Same deriving (Eq, Ord, Enum, Show, Generic)
 
@@ -31,6 +36,12 @@ 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)
+
 normalizePattern :: Pattern -> Pattern
 normalizePattern pat =
     [(key, [val | (key', vals) <- pat, key' == key, val <- vals]) | key <- nub $ map fst pat]
@@ -147,3 +158,26 @@ thawPattern_ cb = bracket (throwNull <$> cb) fcPatternDestroy thawPattern
 withNewPattern cb = bracket (throwNull <$> fcPatternCreate) fcPatternDestroy cb
 foreign import ccall "FcPatternCreate" fcPatternCreate :: IO Pattern_
 foreign import ccall "FcPatternDestroy" fcPatternDestroy :: Pattern_ -> IO ()
+
+------
+--- Pattern
+------
+
+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
+    in (unpack font:fonts, b, tail')
+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
+
+instance PropertyParser Pattern where
+    temp = []
+
+    longhand _ self "font-family" toks
+        | (fonts, True, []) <- parseFontFamily toks = adds "family" Strong fonts self
+    longhand _ _ _ _ = Nothing
diff --git a/Graphics/Text/Font/Choose/Value.hs b/Graphics/Text/Font/Choose/Value.hs
index 2fdbd5a..22d4a02 100644
--- a/Graphics/Text/Font/Choose/Value.hs
+++ b/Graphics/Text/Font/Choose/Value.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric, TypeSynonymInstances, FlexibleInstances #-}
 module Graphics.Text.Font.Choose.Value (Value(..), Value_, withValue, thawValue,
-    value'Size) where
+    value'Size, ToValue(..)) where
 
 import Linear.Matrix (M22)
 import Linear.V2 (V2(..))
@@ -32,6 +32,30 @@ data Value = ValueVoid
 
 instance Hashable Value
 
+class ToValue x where
+    toValue :: x -> Value
+
+instance ToValue () where
+    toValue () = ValueVoid
+instance ToValue Int where
+    toValue = ValueInt
+instance ToValue Double where
+    toValue = ValueDouble
+instance ToValue String where
+    toValue = ValueString
+instance ToValue Bool where
+    toValue = ValueBool
+instance ToValue (M22 Double) where
+    toValue = ValueMatrix
+instance ToValue CharSet where
+    toValue = ValueCharSet
+instance ToValue FT_Face where
+    toValue = ValueFTFace
+instance ToValue LangSet where
+    toValue = ValueLangSet
+instance ToValue Range where
+    toValue = ValueRange
+
 ------
 --- Low-level
 ------
diff --git a/fontconfig-pure.cabal b/fontconfig-pure.cabal
index db22591..d005f28 100644
--- a/fontconfig-pure.cabal
+++ b/fontconfig-pure.cabal
@@ -70,7 +70,8 @@ library
   -- Other library packages from which modules are imported.
   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
+                        hashable >= 1.3 && <2,
+                        css-syntax, text, stylist-traits >= 0.1.1 && < 1
 
   pkgconfig-depends:    fontconfig
 
-- 
2.30.2