{-# LANGUAGE DeriveGeneric, CApiFFI #-} 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 Foreign.C.String (CString, peekCString) import Foreign.Ptr (Ptr) import Control.Exception (throw) import Graphics.Text.Font.Choose.Internal.FFI (withMessage, fromMessage0, withCString') import System.IO.Unsafe (unsafePerformIO) import Graphics.Text.Font.Choose.Value import Graphics.Text.Font.Choose.ObjectSet import Graphics.Text.Font.Choose.Result 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 equalSubset :: Pattern -> Pattern -> ObjectSet -> Bool equalSubset a b os = case withMessage fcPatternEqualSubset [toObject a, toObject b, toObject os] of 0 -> False 1 -> True _ -> throw ErrOOM foreign import capi "fontconfig-wrap.h" fcPatternEqualSubset :: CString -> Int -> Int defaultSubstitute :: Pattern -> Pattern defaultSubstitute = fromMessage0 . withMessage fcDefaultSubstitute foreign import capi "fontconfig-wrap.h" fcDefaultSubstitute :: CString -> Int -> Ptr Int -> CString nameParse :: String -> Pattern nameParse = fromMessage0 . withCString' fcNameParse foreign import capi "fontconfig-wrap.h" fcNameParse :: CString -> Ptr Int -> CString nameUnparse :: Pattern -> String nameUnparse = unsafePerformIO . peekCString . withMessage fcNameUnparse foreign import capi "fontconfig-wrap.h" fcNameUnparse :: CString -> Int -> CString ------ --- 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 -}