{-# 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,
-- For Graphics.Text.Font.Choose.FontSet
parseFontStretch, parseFontWeight, parseFontFeatures, parseFontVars) where
import Data.Map as M
import Data.MessagePack (MessagePack(..), Object(..))
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 Data.Scientific (toRealFloat)
import Data.List (intercalate)
import Data.Maybe as Mb (listToMaybe, fromMaybe, mapMaybe)
type Pattern = Map Text [(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
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 "," $ Prelude.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