10 files changed, 451 insertions(+), 4 deletions(-)

M app/Main.hs
M fontconfig-pure.cabal
A lib/Graphics/Text/Font/Choose/CharSet.hs
A lib/Graphics/Text/Font/Choose/FontSet.hs
A lib/Graphics/Text/Font/Choose/LangSet.hs
A lib/Graphics/Text/Font/Choose/ObjectSet.hs
A lib/Graphics/Text/Font/Choose/Pattern.hs
A lib/Graphics/Text/Font/Choose/Range.hs
A lib/Graphics/Text/Font/Choose/StrSet.hs
A lib/Graphics/Text/Font/Choose/Value.hs

@@ 1,8 1,6 @@
 module Main where
 
-import qualified MyLib (someFunc)
 
 main :: IO ()
 main = do
   putStrLn "Hello, Haskell!"
-  MyLib.someFunc

@@ 63,7 63,10 @@ library
     import:           warnings
 
     -- Modules exported by the library.
-    exposed-modules:  MyLib
+    exposed-modules:  Graphics.Text.Font.Choose.CharSet, Graphics.Text.Font.Choose.LangSet,
+            Graphics.Text.Font.Choose.ObjectSet, Graphics.Text.Font.Choose.Range,
+            Graphics.Text.Font.Choose.StrSet, Graphics.Text.Font.Choose.Value,
+            Graphics.Text.Font.Choose.Pattern, Graphics.Text.Font.Choose.FontSet
 
     -- Modules included in this library but not exported.
     -- other-modules:


@@ 72,7 75,10 @@ library
     -- other-extensions:
 
     -- Other library packages from which modules are imported.
-    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, inline-c
+    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
 
     -- Directories containing source files.
     hs-source-dirs:   lib

@@ 0,0 1,57 @@
+module Graphics.Text.Font.Choose.CharSet where
+
+import Data.IntSet (IntSet, union)
+import qualified Data.IntSet as IntSet
+
+import Data.Char (isHexDigit)
+import Numeric (readHex)
+
+import Data.MessagePack (MessagePack(..))
+
+-- | An FcCharSet is a set of Unicode characters.
+type CharSet = IntSet
+
+parseChar :: String -> Int
+parseChar str | ((x, _):_) <- readHex str = toEnum x
+    | otherwise = 0
+replaceWild :: Char -> String -> String
+replaceWild ch ('?':rest) = ch:replaceWild ch rest
+replaceWild ch (c:cs) = c:replaceWild ch cs
+replaceWild _ "" = ""
+parseWild :: Char -> String -> Int
+parseWild ch str = parseChar $ replaceWild ch str
+-- | Utility for parsing "unicode-range" @font-face property.
+parseCharSet :: String -> Maybe CharSet
+parseCharSet ('U':rest) = parseCharSet ('u':rest) -- lowercase initial "u"
+parseCharSet ('u':'+':cs)
+    | (start@(_:_), '-':ends) <- span isHexDigit cs,
+        (end@(_:_), rest) <- span isHexDigit ends, Just set <- parseCharSet' rest =
+            Just $ union set $ IntSet.fromList [parseChar start..parseChar end]
+    | (codepoint@(_:_), rest) <- span isHexDigit cs, Just set <- parseCharSet' rest =
+        Just $ flip IntSet.insert set $ parseChar codepoint
+    | (codepoint@(_:_), rest) <- span (\c -> isHexDigit c || c == '?') cs,
+        Just set <- parseCharSet' rest =
+            Just $ IntSet.union set $ IntSet.fromList [
+                parseWild '0' codepoint..parseWild 'f' codepoint]
+parseCharSet _ = Nothing
+parseCharSet' :: String -> Maybe CharSet
+parseCharSet' (',':rest) = parseCharSet rest
+parseCharSet' "" = Just IntSet.empty
+parseCharSet' _ = Nothing
+
+-- NOTE: Serial already provides IntSet a CBOR codec, but its quite naive.
+-- I suspect that CharSets are typically quite dense,
+-- So a diff-compression pass should play well with 
+
+diffCompress :: Int -> [Int] -> [Int]
+diffCompress prev (x:xs) = x - prev:diffCompress x xs
+diffCompress _ [] = []
+diffDecompress :: Int -> [Int] -> [Int]
+diffDecompress prev (x:xs) = prev + x:diffDecompress x xs
+diffDecompress _ [] = []
+
+newtype CharSet' = CharSet' { unCharSet :: CharSet }
+instance MessagePack CharSet' where
+    toObject = toObject . diffCompress 0 . IntSet.toAscList . unCharSet
+    fromObject msg =
+        CharSet' <$> IntSet.fromAscList <$> diffDecompress 0 <$> fromObject msg

@@ 0,0 1,81 @@
+module Graphics.Text.Font.Choose.FontSet where
+
+import Graphics.Text.Font.Choose.Pattern
+
+type FontSet = [Pattern']
+
+------
+--- CSS Bindings
+------
+
+-- | `StyleSheet` wrapper to parse @font-face rules.
+data FontFaceParser a = FontFaceParser { cssFonts :: FontSet, cssInner :: a}
+
+{- parseFontFaceSrc (Function "local":Ident name:RightParen:Comma:rest) =
+    ("local:" ++ unpack name):parseFontFaceSrc rest
+parseFontFaceSrc (Function "local":String name:RightParen:Comma:rest) =
+    ("local:" ++ unpack name):parseFontFaceSrc rest
+parseFontFaceSrc (Function "local":Ident name:RightParen:[]) = ["local:" ++ unpack name]
+parseFontFaceSrc (Function "local":String name:RightParen:[]) = ["local:" ++ unpack name]
+
+parseFontFaceSrc (Url link:toks)
+    | Comma:rest <- skipMeta toks = unpack link:parseFontFaceSrc rest
+    | [] <- skipMeta toks = [unpack link]
+    | otherwise = [""] -- Error indicator!
+  where
+    skipMeta (Function "format":Ident _:RightParen:rest) = skipMeta rest
+    skipMeta (Function "format":String _:RightParen:rest) = skipMeta rest
+    skipMeta (Function "tech":Ident _:RightParen:rest) = skipMeta rest
+    skipMeta (Function "tech":String _:RightParen:rest) = skipMeta rest
+    skipMeta toks = toks
+
+parseFontFaceSrc _ = [""]
+
+properties2font :: [(Text, [Token])] -> Pattern
+properties2font (("font-family", [String font]):props) =
+    setValue "family" Strong (unpack font) $ properties2font props
+properties2font (("font-family", [Ident font]):props) =
+    setValue "family" Strong (unpack font) $ properties2font props
+
+properties2font (("font-stretch", [tok]):props) | Just x <- parseFontStretch tok =
+    setValue "width" Strong x $ properties2font props
+properties2font (("font-stretch", [start, end]):props)
+    | Just x <- parseFontStretch start, Just y <- parseFontStretch end =
+        setValue "width" Strong (x `iRange` y) $ properties2font props
+
+properties2font (("font-weight", [tok]):props) | Just x <- parseFontWeight tok =
+    setValue "width" Strong x $ properties2font props
+properties2font (("font-weight", [start, end]):props)
+    | Just x <- parseFontStretch start, Just y <- parseFontStretch end =
+        setValue "weight" Strong (x `iRange` y) $ properties2font props
+
+properties2font (("font-feature-settings", toks):props)
+    | (features, True, []) <- parseFontFeatures toks =
+        setValue "fontfeatures" Strong (intercalate "," $ map fst features) $
+            properties2font props
+
+properties2font (("font-variation-settings", toks):props)
+    | (_, True, []) <- parseFontVars toks =
+        setValue "variable" Strong True $ properties2font props
+
+properties2font (("unicode-range", toks):props)
+    | Just chars <- parseCharSet $ unpack $ serialize toks =
+        setValue "charset" Strong chars $ properties2font props
+
+-- Ignoring metadata & trusting in FreeType's broad support for fonts.
+properties2font (("src", toks):props)
+    | fonts@(_:_) <- parseFontFaceSrc toks, "" `notElem` fonts =
+        setValue "web-src" Strong (intercalate "\t" fonts) $ properties2font props
+
+properties2font (_:props) = properties2font props
+properties2font [] = []
+
+instance StyleSheet a => StyleSheet (FontFaceParser a) where
+    setPriorities v (FontFaceParser x self) = FontFaceParser x $ setPriorities v self
+    addRule (FontFaceParser x self) rule = FontFaceParser x $ addRule self rule
+
+    addAtRule (FontFaceParser fonts self) "font-face" toks =
+        let ((props, _), toks') = parseProperties toks
+        in (FontFaceParser (properties2font props:fonts) self, toks')
+    addAtRule (FontFaceParser x self) key toks =
+        let (a, b) = addAtRule self key toks in (FontFaceParser x a, b) -}

@@ 0,0 1,15 @@
+module Graphics.Text.Font.Choose.LangSet where
+
+import Data.Set (Set)
+import qualified Data.Set as S
+
+import Data.MessagePack (MessagePack(..))
+
+type LangSet = Set String
+newtype LangSet' = LangSet' { unLangSet :: LangSet }
+
+instance MessagePack LangSet' where
+    toObject = toObject . S.toList . unLangSet
+    fromObject msg = LangSet' <$> S.fromList <$> fromObject msg
+
+-- TODO: Implement language bindings! But first: Datamodel everything!

@@ 0,0 1,5 @@
+module Graphics.Text.Font.Choose.ObjectSet where
+
+type ObjectSet = [String]
+
+-- NOTE: Already has all the typeclass instances I want, including MessagePack!

@@ 0,0 1,155 @@
+{-# LANGUAGE DeriveGeneric #-}
+module Graphics.Text.Font.Choose.Pattern where
+
+import Data.Map as M
+import Data.MessagePack (MessagePack(..), Object(..))
+import Data.Hashable (Hashable(..))
+import GHC.Generics (Generic)
+
+import Graphics.Text.Font.Choose.Value
+
+type Pattern = Map String [(Binding, Value)]
+data Pattern' = Pattern' { unPattern :: Pattern }
+data Binding = Strong | Weak | Same deriving (Eq, Ord, Enum, Read, Show, Generic)
+
+instance Hashable Binding where
+    hash = fromEnum
+instance MessagePack Binding where
+    fromObject (ObjectBool True) = Just Strong
+    fromObject (ObjectBool False) = Just Weak
+    fromObject ObjectNil = Just Same
+    fromObject _ = Nothing
+    toObject Strong = ObjectBool True
+    toObject Weak = ObjectBool False
+    toObject Same = ObjectNil
+
+------
+--- CSS
+------
+
+{-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!
+
+parseFontFeatures :: [Token] -> ([(String, Int)], Bool, [Token])
+parseFontFeatures (String feat:toks) | feature@(_:_:_:_:[]) <- unpack feat = case toks of
+    Comma:tail -> let (feats, b, tail') = parseFontFeatures tail in ((feature, 1):feats, b, tail')
+    Ident "on":Comma:tail -> let (f, b, t) = parseFontFeatures tail in ((feature, 1):f, b, t)
+    Ident "on":tail -> ([(feature, 1)], True, tail)
+    Ident "off":Comma:tail -> let (f, b, t) = parseFontFeatures tail in ((feature, 1):f, b, t)
+    Ident "off":tail -> ([(feature, 1)], True, tail)
+    Number _ (NVInteger x):Comma:tail ->
+        let (feats, b, tail') = parseFontFeatures tail in ((feature, fromEnum x):feats, b, tail')
+    Number _ (NVInteger x):tail -> ([(feature, fromEnum x)], True, tail)
+parseFontFeatures toks = ([], False, toks)
+
+parseFontVars :: [Token] -> ([(String, Double)], Bool, [Token])
+parseFontVars (String var':Number _ x:Comma:tail) | var@(_:_:_:_:[]) <- unpack var' =
+    let (vars, b, tail') = parseFontVars tail in ((var, nv2double x):vars, b, tail')
+parseFontVars (String var':Number _ x:tail) | var@(_:_:_:_:[]) <- unpack var' =
+    ([(var, nv2double x)], True, tail)
+parseFontVars toks = ([], False, toks)
+
+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
+
+parseFontStretch :: Token -> Maybe Int -- Result in percentages
+parseFontStretch (Percentage _ x) = Just $ fromEnum $ nv2double x
+parseFontStretch (Ident "ultra-condensed") = Just 50
+parseFontStretch (Ident "extra-condensed") = Just 63 -- 62.5%, but round towards 100%
+parseFontStretch (Ident "condensed") = Just 75
+parseFontStretch (Ident "semi-condensed") = Just 88 -- 87.5% actually...
+parseFontStretch (Ident "normal") = Just 100
+parseFontStretch (Ident "initial") = Just 100
+parseFontStretch (Ident "semi-expanded") = Just 112 -- 112.5% actually...
+parseFontStretch (Ident "expanded") = Just 125
+parseFontStretch (Ident "extra-expanded") = Just 150
+parseFontStretch (Ident "ultra-expanded") = Just 200
+parseFontStretch _ = Nothing
+
+-- Conversion between CSS scale & FontConfig scale is non-trivial, use lookuptable.
+parseFontWeight :: Token -> Maybe Int
+parseFontWeight (Ident k) | k `elem` ["initial", "normal"] = Just 80
+parseFontWeight (Ident "bold") = Just 200
+parseFontWeight (Number _ (NVInteger x)) = Just $ weightFromOpenType $ fromEnum x
+parseFontWeight _ = Nothing
+
+nv2double (NVInteger x) = fromInteger x
+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
+
+getSize pat | ValueDouble x <- getValue "size" pat = x
+    | otherwise = 10
+
+instance PropertyParser Pattern where
+    temp = []
+
+    longhand _ self "font-family" toks
+        | (fonts, True, []) <- parseFontFamily toks = sets "family" Strong fonts self
+
+    -- font-size: initial should be configurable!
+    longhand super self "font-size" [Dimension _ x unit]
+        | let y = parseLength (getSize super) x unit, not $ isNaN y =
+            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
+
+    -- 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
+    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
+        -- 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 -}

@@ 0,0 1,21 @@
+module Graphics.Text.Font.Choose.Range where
+
+import Data.MessagePack (MessagePack(..), Object(..))
+import qualified Data.Vector as V
+import qualified Data.IntMap as IM
+
+-- | Matches a numeric range.
+data Range = Range Double Double deriving (Eq, Show, Ord)
+-- | Matches an integral range.
+iRange :: Int -> Int -> Range
+iRange i j = toEnum i `Range` toEnum j
+
+instance MessagePack Range where
+    toObject (Range start end) = ObjectMap $ V.fromList [
+        (ObjectInt 0, ObjectDouble start),
+        (ObjectInt 1, ObjectDouble end)
+      ]
+    fromObject msg
+        | Just msg' <- fromObject msg =
+            Just (IM.findWithDefault 0 0 msg' `Range` IM.findWithDefault 0 1 msg')
+        | otherwise = Nothing

@@ 0,0 1,12 @@
+module Graphics.Text.Font.Choose.StrSet where
+
+import Data.Set (Set)
+import qualified Data.Set as S
+
+import Data.MessagePack (MessagePack(..))
+
+newtype StrSet = StrSet { unStrSet :: Set String }
+
+instance MessagePack StrSet where
+    toObject = toObject . S.toList . unStrSet
+    fromObject msg = StrSet <$> S.fromList <$> fromObject msg

@@ 0,0 1,97 @@
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+module Graphics.Text.Font.Choose.Value where
+
+import Linear.Matrix (M22)
+import Linear.V2 (V2(..))
+import Graphics.Text.Font.Choose.CharSet (CharSet, CharSet'(..))
+--import FreeType.Core.Base (FT_Face(..))
+import Graphics.Text.Font.Choose.LangSet (LangSet, LangSet'(..))
+import Graphics.Text.Font.Choose.Range (Range)
+
+import Data.MessagePack (MessagePack(..), Object(..))
+import qualified Data.Text as Txt
+
+-- | A dynamic type system for `Pattern`s.
+data Value = ValueVoid
+    | ValueInt Int
+    | ValueDouble Double
+    | ValueString String
+    | ValueBool Bool
+    | ValueMatrix (M22 Double)
+    | ValueCharSet CharSet
+--    | ValueFTFace FT_Face -- FIXME: Is it worth going through the trouble to bridge this?
+    | ValueLangSet LangSet
+    | ValueRange Range deriving (Eq, Show, Ord)
+
+instance MessagePack Value where
+    toObject ValueVoid = ObjectNil
+    toObject (ValueInt x) = ObjectInt x
+    toObject (ValueDouble x) = ObjectDouble x
+    toObject (ValueString x) = ObjectStr $ Txt.pack x
+    toObject (ValueBool x) = ObjectBool x
+    toObject (ValueMatrix (V2 (V2 xx yx) (V2 xy yy))) = toObject [xx, xy, yx, yy]
+    toObject (ValueCharSet x) = toObject $ CharSet' x
+    toObject (ValueLangSet x) = toObject $ LangSet' x
+    toObject (ValueRange x) = toObject x
+
+    fromObject ObjectNil = Just ValueVoid
+    fromObject (ObjectBool x) = Just $ ValueBool x
+    fromObject (ObjectInt x) = Just $ ValueInt x
+    fromObject (ObjectFloat x) = Just $ ValueDouble $ realToFrac x
+    fromObject (ObjectDouble x) = Just $ ValueDouble x
+    fromObject (ObjectStr x) = Just $ ValueString $ Txt.unpack x
+    fromObject (ObjectBin _) = Nothing -- Would use for to transfer font faces via underlying bytes.
+    fromObject msg
+        | Just charset <- fromObject msg = Just $ ValueCharSet $ unCharSet charset
+        | Just langset <- fromObject msg = Just $ ValueLangSet $ unLangSet langset
+        | Just range <- fromObject msg = Just $ ValueRange range
+        | Just [xx, xy, yx, yy] <- fromObject msg :: Maybe [Double] =
+            -- [Double] decoding is overly generous, potentially conflicts with above.
+            Just $ ValueMatrix $ V2 (V2 xx yx) (V2 xy yy)
+        | otherwise = Nothing
+
+-- | Coerces compiletime types to runtime types.
+class ToValue x where
+    toValue :: x -> Value
+    fromValue :: Value -> Maybe x
+    fromValue' :: Value -> x -- throws Result.Error
+    fromValue' self | Just ret <- fromValue self = ret
+    fromValue' _ = error "Type mismatch!" -- TODO: Throw something nicer!
+
+instance ToValue () where
+    toValue () = ValueVoid
+    fromValue ValueVoid = Just ()
+    fromValue _ = Nothing
+instance ToValue Int where
+    toValue = ValueInt
+    fromValue (ValueInt x) = Just x
+    fromValue _ = Nothing
+instance ToValue Double where
+    toValue = ValueDouble
+    fromValue (ValueDouble x) = Just x
+    fromValue _ = Nothing
+instance ToValue String where
+    toValue = ValueString
+    fromValue (ValueString x) = Just x
+    fromValue _ = Nothing
+instance ToValue Bool where
+    toValue = ValueBool
+    fromValue (ValueBool x) = Just x
+    fromValue _ = Nothing
+instance ToValue (M22 Double) where
+    toValue = ValueMatrix
+    fromValue (ValueMatrix x) = Just x
+    fromValue _ = Nothing
+instance ToValue CharSet' where
+    toValue = ValueCharSet . unCharSet
+    fromValue (ValueCharSet x) = Just $ CharSet' x
+    fromValue _ = Nothing
+--instance ToValue FT_Face where
+--    toValue = ValueFTFace
+--    fromValue (ValueFTFace x) = Just x
+--    fromValue _ = Nothing
+instance ToValue LangSet' where
+    toValue = ValueLangSet . unLangSet
+    fromValue (ValueLangSet x) = Just $ LangSet' x
+    fromValue _ = Nothing
+