{-# LANGUAGE DeriveGeneric, CApiFFI #-} {-# LANGUAGE OverloadedStrings #-} module Graphics.Text.Font.Choose.Pattern(Pattern, Pattern'(..), module M, Binding(..), setValue, setValues, getValue, getValues, equalSubset, defaultSubstitute, nameParse, nameUnparse, nameFormat, validPattern, validPattern', -- For Graphics.Text.Font.Choose.FontSet parseFontStretch, parseFontWeight, parseFontFeatures, parseFontVars) where import Data.Map as M import Data.MessagePack (MessagePack(..), Object(..)) import Test.QuickCheck (Arbitrary(..), elements) import Data.Hashable (Hashable(..)) import GHC.Generics (Generic) import Foreign.C.String (CString) import Foreign.Ptr (Ptr) import Control.Exception (throw) import Graphics.Text.Font.Choose.Internal.FFI (withMessage, fromMessage0, withCString', peekCString') import Graphics.Text.Font.Choose.Value import Graphics.Text.Font.Choose.ObjectSet import Graphics.Text.Font.Choose.Result import Graphics.Text.Font.Choose.Weight import Stylist (PropertyParser(..)) import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..)) import Data.Text (Text, unpack) import qualified Data.Text as Txt import Data.Scientific (toRealFloat) import Data.List (intercalate) import Data.Maybe as Mb (listToMaybe, fromMaybe, mapMaybe) import Data.Char (isAscii) import Prelude as L type Pattern = M.Map Text [(Binding, Value)] data Pattern' = Pattern' { unPattern :: Pattern } deriving (Eq, Read, Show, Generic) 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 instance Hashable Pattern' where hash = hash . unPattern instance MessagePack Pattern' where fromObject = fmap Pattern' . fromObject toObject = toObject . unPattern instance Arbitrary Pattern' where -- FIXME: Stop enforcing singletons, without incurring too many invalid patterns! arbitrary = Pattern' <$> M.mapKeys normKey <$> M.map (:[]) <$> arbitrary where normKey = Txt.pack . L.filter (/= '\0') . L.map toAscii . L.take 17 toAscii :: Char -> Char toAscii ch = toEnum $ fromEnum ch `mod` 128 instance Arbitrary Binding where arbitrary = elements [Strong, Weak] -- Same doesn't roundtrip! validPattern :: Pattern -> Bool validPattern self = not (M.null self) && all (validValue . snd) (concat $ M.elems self) && all (not . L.null) (M.elems self) && all (not . Txt.null) (M.keys self) && all ((/= Same) . fst) (concat $ M.elems self) && all (not . Txt.elem '\0') (M.keys self) && all (Txt.all isAscii) (M.keys self) && all (\k -> Txt.length k < 18) (M.keys self) validPattern' :: Pattern' -> Bool validPattern' = validPattern . unPattern 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 getValue :: ToValue v => Text -> Pattern -> Maybe v getValue key self = fromValue . snd =<< listToMaybe =<< M.lookup key self getValues :: ToValue v => Text -> Pattern -> [v] getValues key self = Mb.mapMaybe (fromValue . snd) $ fromMaybe [] $ M.lookup key self 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 = peekCString' . withMessage fcNameUnparse foreign import capi "fontconfig-wrap.h" fcNameUnparse :: CString -> Int -> CString nameFormat :: Pattern -> String -> String nameFormat a b = peekCString' $ flip withCString' b $ withMessage fcNameFormat a foreign import capi "fontconfig-wrap.h" fcNameFormat :: CString -> Int -> CString -> CString ------ --- CSS ------ parseFontFamily :: [Token] -> ([String], Bool, [Token]) parseFontFamily (String font:Comma:toks) = let (fonts, b, tail') = parseFontFamily toks in (unpack font:fonts, b, tail') parseFontFamily (Ident font:Comma:toks) = let (fonts, b, tail') = parseFontFamily toks in (unpack font:fonts, b, tail') parseFontFamily (String font:toks) = ([unpack font], True, toks) parseFontFamily (Ident font:toks) = ([unpack font], True, toks) parseFontFamily toks = ([], False, toks) -- Invalid syntax! parseFontFeatures :: [Token] -> ([(String, Int)], Bool, [Token]) parseFontFeatures (String feat:toks) | feature@(_:_:_:_:[]) <- unpack feat = case toks of Comma:toks' -> let (feats, b, tail') = parseFontFeatures toks' in ((feature, 1):feats, b, tail') Ident "on":Comma:toks' -> let (f, b, t) = parseFontFeatures toks' in ((feature, 1):f, b, t) Ident "on":toks' -> ([(feature, 1)], True, toks') Ident "off":Comma:toks' -> let (f, b, t) = parseFontFeatures toks' in ((feature, 1):f, b, t) Ident "off":toks' -> ([(feature, 1)], True, toks') Number _ (NVInteger x):Comma:toks' -> let (feats, b, tail') = parseFontFeatures toks' in ((feature, fromEnum x):feats, b, tail') Number _ (NVInteger x):toks' -> ([(feature, fromEnum x)], True, toks') _ -> ([], False, String feat:toks) parseFontFeatures toks = ([], False, toks) parseFontVars :: [Token] -> ([(String, Double)], Bool, [Token]) parseFontVars (String var':Number _ x:Comma:toks) | var@(_:_:_:_:[]) <- unpack var' = let (vars, b, tail') = parseFontVars toks in ((var, nv2double x):vars, b, tail') parseFontVars (String var':Number _ x:toks) | var@(_:_:_:_:[]) <- unpack var' = ([(var, nv2double x)], True, toks) parseFontVars toks = ([], False, toks) parseLength :: Double -> NumericValue -> Text -> Double parseLength super len unit = convert (nv2double len) 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 :: NumericValue -> Double nv2double (NVInteger x) = fromInteger x nv2double (NVNumber x) = toRealFloat x sets :: ToValue v => Text -> Binding -> [v] -> Pattern -> Maybe Pattern sets a b c d = Just $ setValues a b c d set :: ToValue v => Text -> Binding -> v -> Pattern -> Maybe Pattern set a b c d = Just $ setValue a b c d seti :: Text -> Binding -> Int -> Pattern -> Maybe Pattern seti a b c d = Just $ setValue a b (c :: Int) d unset' :: Text -> Pattern -> Maybe Pattern unset' a b = Just $ M.delete a b getSize :: Pattern -> Double getSize pat | Just [(_, ValueDouble x)] <- M.lookup "size" pat = x | otherwise = 10 instance PropertyParser Pattern' where temp = Pattern' M.empty longhand _ (Pattern' self) "font-family" toks | (fonts, True, []) <- parseFontFamily toks = Pattern' <$> sets "family" Strong fonts self -- font-size: initial should be configurable! longhand (Pattern' super) (Pattern' self) "font-size" [Dimension _ x unit] | let y = parseLength (getSize super) x unit, not $ isNaN y = Pattern' <$> set "size" Strong y self longhand super self "font-size" [Percentage x y] = longhand super self "font-size" [Dimension x y "%"] 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. -- 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 _ (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. | 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 "," $ L.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