{-# 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 -}