{-# LANGUAGE DeriveGeneric, OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
module Graphics.Text.Font.Choose.Pattern (Pattern(..), Binding(..), equalSubset,
    normalizePattern, filter, defaultSubstitute, nameParse, nameUnparse, format,
    Pattern_, withPattern, thawPattern, thawPattern_, patternAsPointer,

    setValue, setValues, unset, getValues, getValues', getValue, getValue', getValue0,
    parseFontFamily, parseFontFeatures, parseFontVars, parseLength,
    parseFontStretch, parseFontWeight) where

import Prelude hiding (filter)
import Data.List (nub)

import Graphics.Text.Font.Choose.Value
import Graphics.Text.Font.Choose.ObjectSet (ObjectSet, ObjectSet_, withObjectSet)
import Data.Hashable (Hashable(..))
import GHC.Generics (Generic)
import Graphics.Text.Font.Choose.Result (throwFalse, throwNull, throwInt)

import Foreign.Ptr (Ptr)
import Foreign.Marshal.Alloc (alloca, allocaBytes, free)
import Foreign.Storable (Storable(..))
import Foreign.C.String (CString, withCString, peekCString)
import Debug.Trace (trace) -- For reporting internal errors!
import System.IO.Unsafe (unsafePerformIO)

import Control.Monad (forM, join)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Control.Exception (bracket)

-- Imported for CSS bindings
import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Data.Text (unpack, Text)
import Stylist (PropertyParser(..))
import Data.Scientific (toRealFloat)
import Data.List (intercalate)
import Graphics.Text.Font.Choose.Weight (weightFromOpenType)

-- | An `Pattern`` holds a set of names with associated value lists;
-- each name refers to a property of a font.
-- `Pattern`s are used as inputs to the matching code as well as
-- holding information about specific fonts.
-- Each property can hold one or more values;
-- conventionally all of the same type, although the interface doesn't demand that.
type Pattern = [(String, [(Binding, Value)])]
-- | How important is it to match this property of the Pattern.
data Binding = Strong | Weak | Same deriving (Binding -> Binding -> Bool
(Binding -> Binding -> Bool)
-> (Binding -> Binding -> Bool) -> Eq Binding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Binding -> Binding -> Bool
$c/= :: Binding -> Binding -> Bool
== :: Binding -> Binding -> Bool
$c== :: Binding -> Binding -> Bool
Eq, Eq Binding
Eq Binding =>
(Binding -> Binding -> Ordering)
-> (Binding -> Binding -> Bool)
-> (Binding -> Binding -> Bool)
-> (Binding -> Binding -> Bool)
-> (Binding -> Binding -> Bool)
-> (Binding -> Binding -> Binding)
-> (Binding -> Binding -> Binding)
-> Ord Binding
Binding -> Binding -> Bool
Binding -> Binding -> Ordering
Binding -> Binding -> Binding
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Binding -> Binding -> Binding
$cmin :: Binding -> Binding -> Binding
max :: Binding -> Binding -> Binding
$cmax :: Binding -> Binding -> Binding
>= :: Binding -> Binding -> Bool
$c>= :: Binding -> Binding -> Bool
> :: Binding -> Binding -> Bool
$c> :: Binding -> Binding -> Bool
<= :: Binding -> Binding -> Bool
$c<= :: Binding -> Binding -> Bool
< :: Binding -> Binding -> Bool
$c< :: Binding -> Binding -> Bool
compare :: Binding -> Binding -> Ordering
$ccompare :: Binding -> Binding -> Ordering
$cp1Ord :: Eq Binding
Ord, Int -> Binding
Binding -> Int
Binding -> [Binding]
Binding -> Binding
Binding -> Binding -> [Binding]
Binding -> Binding -> Binding -> [Binding]
(Binding -> Binding)
-> (Binding -> Binding)
-> (Int -> Binding)
-> (Binding -> Int)
-> (Binding -> [Binding])
-> (Binding -> Binding -> [Binding])
-> (Binding -> Binding -> [Binding])
-> (Binding -> Binding -> Binding -> [Binding])
-> Enum Binding
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Binding -> Binding -> Binding -> [Binding]
$cenumFromThenTo :: Binding -> Binding -> Binding -> [Binding]
enumFromTo :: Binding -> Binding -> [Binding]
$cenumFromTo :: Binding -> Binding -> [Binding]
enumFromThen :: Binding -> Binding -> [Binding]
$cenumFromThen :: Binding -> Binding -> [Binding]
enumFrom :: Binding -> [Binding]
$cenumFrom :: Binding -> [Binding]
fromEnum :: Binding -> Int
$cfromEnum :: Binding -> Int
toEnum :: Int -> Binding
$ctoEnum :: Int -> Binding
pred :: Binding -> Binding
$cpred :: Binding -> Binding
succ :: Binding -> Binding
$csucc :: Binding -> Binding
Enum, Int -> Binding -> ShowS
[Binding] -> ShowS
Binding -> String
(Int -> Binding -> ShowS)
-> (Binding -> String) -> ([Binding] -> ShowS) -> Show Binding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Binding] -> ShowS
$cshowList :: [Binding] -> ShowS
show :: Binding -> String
$cshow :: Binding -> String
showsPrec :: Int -> Binding -> ShowS
$cshowsPrec :: Int -> Binding -> ShowS
Show, (forall x. Binding -> Rep Binding x)
-> (forall x. Rep Binding x -> Binding) -> Generic Binding
forall x. Rep Binding x -> Binding
forall x. Binding -> Rep Binding x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Binding x -> Binding
$cfrom :: forall x. Binding -> Rep Binding x
Generic)

instance Hashable Binding where
    hash :: Binding -> Int
hash Strong = 0
    hash Weak = 1
    hash Same = 2

-- | Replaces the values under the given "key" in given "pattern"
-- with given "binding" & "value".
setValue :: ToValue x => String -> Binding -> x -> Pattern -> Pattern
setValue :: String -> Binding -> x -> Pattern -> Pattern
setValue key :: String
key b :: Binding
b value :: x
value pat :: Pattern
pat = (String
key, [(Binding
b, x -> Value
forall x. ToValue x => x -> Value
toValue x
value)])(String, [(Binding, Value)]) -> Pattern -> Pattern
forall a. a -> [a] -> [a]
:String -> Pattern -> Pattern
forall a b. Eq a => a -> [(a, b)] -> [(a, b)]
unset String
key Pattern
pat
-- | Replaces the values under the given "key" in given "pattern"
-- with given "binding" & "value"s.
setValues :: ToValue x => String -> Binding -> [x] -> Pattern -> Pattern
setValues :: String -> Binding -> [x] -> Pattern -> Pattern
setValues key :: String
key b :: Binding
b values :: [x]
values pat :: Pattern
pat = (String
key, [(Binding
b, x -> Value
forall x. ToValue x => x -> Value
toValue x
v) | x
v <- [x]
values])(String, [(Binding, Value)]) -> Pattern -> Pattern
forall a. a -> [a] -> [a]
:String -> Pattern -> Pattern
forall a b. Eq a => a -> [(a, b)] -> [(a, b)]
unset String
key Pattern
pat
-- | Retrieves all values in the given pattern under a given key.
getValues :: String -> Pattern -> [Value]
getValues :: String -> Pattern -> [Value]
getValues key :: String
key pat :: Pattern
pat | Just ret :: [(Binding, Value)]
ret <- String -> Pattern -> Maybe [(Binding, Value)]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
key Pattern
pat = ((Binding, Value) -> Value) -> [(Binding, Value)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Binding, Value) -> Value
forall a b. (a, b) -> b
snd [(Binding, Value)]
ret
    | Bool
otherwise = []
-- | Retrieves all values under a given key & coerces to desired `Maybe` type.
getValues' :: String -> Pattern -> [b]
getValues' key :: String
key pat :: Pattern
pat = (Value -> Maybe b) -> [Value] -> [b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Value -> Maybe b
forall x. ToValue x => Value -> Maybe x
fromValue ([Value] -> [b]) -> [Value] -> [b]
forall a b. (a -> b) -> a -> b
$ String -> Pattern -> [Value]
getValues String
key Pattern
pat
-- | Retrieves first value in the given pattern under a given key.
getValue :: String -> Pattern -> Value
getValue :: String -> Pattern -> Value
getValue key :: String
key pat :: Pattern
pat | Just ((_, ret :: Value
ret):_) <- String -> Pattern -> Maybe [(Binding, Value)]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
key Pattern
pat = Value
ret
    | Bool
otherwise = Value
ValueVoid
-- Retrieves first value under a given key & coerces to desired `Maybe` type.
getValue' :: ToValue x => String -> Pattern -> Maybe x
getValue' :: String -> Pattern -> Maybe x
getValue' key :: String
key pat :: Pattern
pat = Value -> Maybe x
forall x. ToValue x => Value -> Maybe x
fromValue (Value -> Maybe x) -> Value -> Maybe x
forall a b. (a -> b) -> a -> b
$ String -> Pattern -> Value
getValue String
key Pattern
pat
-- Retrieves first value under a given key & coerces to desired type throw
-- or throw `ErrTypeMismatch`
getValue0 :: ToValue x => String -> Pattern -> x
getValue0 :: String -> Pattern -> x
getValue0 key :: String
key pat :: Pattern
pat = Value -> x
forall x. ToValue x => Value -> x
fromValue' (Value -> x) -> Value -> x
forall a b. (a -> b) -> a -> b
$ String -> Pattern -> Value
getValue String
key Pattern
pat

-- | Deletes all entries in the given pattern under a given key.
unset :: a -> [(a, b)] -> [(a, b)]
unset key :: a
key mapping :: [(a, b)]
mapping = [(a
key', b
val') | (key' :: a
key', val' :: b
val') <- [(a, b)]
mapping, a
key' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
key]

-- | Restructures a `Pattern` so each key repeats at most once.
normalizePattern :: Pattern -> Pattern
normalizePattern :: Pattern -> Pattern
normalizePattern pat :: Pattern
pat =
    [(String
key, [(Binding, Value)
val | (key' :: String
key', vals :: [(Binding, Value)]
vals) <- Pattern
pat, String
key' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
key, (Binding, Value)
val <- [(Binding, Value)]
vals]) | String
key <- [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ((String, [(Binding, Value)]) -> String) -> Pattern -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, [(Binding, Value)]) -> String
forall a b. (a, b) -> a
fst Pattern
pat]

-- | Returns whether pa and pb have exactly the same values for all of the objects in os.
equalSubset :: Pattern -> Pattern -> ObjectSet -> Bool
equalSubset :: Pattern -> Pattern -> [String] -> Bool
equalSubset a :: Pattern
a b :: Pattern
b objs :: [String]
objs = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Pattern -> (Pattern_ -> IO Bool) -> IO Bool
forall a. Pattern -> (Pattern_ -> IO a) -> IO a
withPattern Pattern
a ((Pattern_ -> IO Bool) -> IO Bool)
-> (Pattern_ -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \a' :: Pattern_
a' -> Pattern -> (Pattern_ -> IO Bool) -> IO Bool
forall a. Pattern -> (Pattern_ -> IO a) -> IO a
withPattern Pattern
b ((Pattern_ -> IO Bool) -> IO Bool)
-> (Pattern_ -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \b' :: Pattern_
b' ->
    [String] -> (ObjectSet_ -> IO Bool) -> IO Bool
forall a. [String] -> (ObjectSet_ -> IO a) -> IO a
withObjectSet [String]
objs ((ObjectSet_ -> IO Bool) -> IO Bool)
-> (ObjectSet_ -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ Pattern_ -> Pattern_ -> ObjectSet_ -> IO Bool
fcPatternEqualSubset Pattern_
a' Pattern_
b'
foreign import ccall "FcPatternEqualSubset" fcPatternEqualSubset ::
    Pattern_ -> Pattern_ -> ObjectSet_ -> IO Bool

-- | Returns a new pattern that only has those objects from p that are in os.
-- If os is NULL, a duplicate of p is returned.
filter :: Pattern -> ObjectSet -> Pattern
filter :: Pattern -> [String] -> Pattern
filter pat :: Pattern
pat objs :: [String]
objs =
    IO Pattern -> Pattern
forall a. IO a -> a
unsafePerformIO (IO Pattern -> Pattern) -> IO Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> (Pattern_ -> IO Pattern) -> IO Pattern
forall a. Pattern -> (Pattern_ -> IO a) -> IO a
withPattern Pattern
pat ((Pattern_ -> IO Pattern) -> IO Pattern)
-> (Pattern_ -> IO Pattern) -> IO Pattern
forall a b. (a -> b) -> a -> b
$ \pat' :: Pattern_
pat' -> [String] -> (ObjectSet_ -> IO Pattern) -> IO Pattern
forall a. [String] -> (ObjectSet_ -> IO a) -> IO a
withObjectSet [String]
objs ((ObjectSet_ -> IO Pattern) -> IO Pattern)
-> (ObjectSet_ -> IO Pattern) -> IO Pattern
forall a b. (a -> b) -> a -> b
$ \objs' :: ObjectSet_
objs' ->
        IO Pattern_ -> IO Pattern
thawPattern_ (IO Pattern_ -> IO Pattern) -> IO Pattern_ -> IO Pattern
forall a b. (a -> b) -> a -> b
$ Pattern_ -> ObjectSet_ -> IO Pattern_
fcPatternFilter Pattern_
pat' ObjectSet_
objs'
foreign import ccall "FcPatternFilter" fcPatternFilter ::
    Pattern_ -> ObjectSet_ -> IO Pattern_

-- | Supplies default values for underspecified font patterns:
-- * Patterns without a specified style or weight are set to Medium
-- * Patterns without a specified style or slant are set to Roman
-- * Patterns without a specified pixel size are given one computed from any
-- specified point size (default 12), dpi (default 75) and scale (default 1).
defaultSubstitute :: Pattern -> Pattern
defaultSubstitute :: Pattern -> Pattern
defaultSubstitute pat :: Pattern
pat = IO Pattern -> Pattern
forall a. IO a -> a
unsafePerformIO (IO Pattern -> Pattern) -> IO Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> (Pattern_ -> IO Pattern) -> IO Pattern
forall a. Pattern -> (Pattern_ -> IO a) -> IO a
withPattern Pattern
pat ((Pattern_ -> IO Pattern) -> IO Pattern)
-> (Pattern_ -> IO Pattern) -> IO Pattern
forall a b. (a -> b) -> a -> b
$ \pat' :: Pattern_
pat' -> do
    ()
ret <- Pattern_ -> IO ()
fcDefaultSubstitute Pattern_
pat'
    Pattern_ -> IO Pattern
thawPattern Pattern_
pat'
foreign import ccall "FcDefaultSubstitute" fcDefaultSubstitute :: Pattern_ -> IO ()

-- Is this correct memory management?
-- | Converts name from the standard text format described above into a pattern.
nameParse :: String -> Pattern
nameParse :: String -> Pattern
nameParse name :: String
name = IO Pattern -> Pattern
forall a. IO a -> a
unsafePerformIO (IO Pattern -> Pattern) -> IO Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ String -> (CString -> IO Pattern) -> IO Pattern
forall a. String -> (CString -> IO a) -> IO a
withCString String
name ((CString -> IO Pattern) -> IO Pattern)
-> (CString -> IO Pattern) -> IO Pattern
forall a b. (a -> b) -> a -> b
$ \name' :: CString
name' ->
    IO Pattern_ -> IO Pattern
thawPattern_ (IO Pattern_ -> IO Pattern) -> IO Pattern_ -> IO Pattern
forall a b. (a -> b) -> a -> b
$ CString -> IO Pattern_
fcNameParse CString
name'
foreign import ccall "FcNameParse" fcNameParse :: CString -> IO Pattern_

-- | Converts the given pattern into the standard text format described above.
nameUnparse :: Pattern -> String
nameUnparse :: Pattern -> String
nameUnparse pat :: Pattern
pat = IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ Pattern -> (Pattern_ -> IO String) -> IO String
forall a. Pattern -> (Pattern_ -> IO a) -> IO a
withPattern Pattern
pat ((Pattern_ -> IO String) -> IO String)
-> (Pattern_ -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \pat' :: Pattern_
pat' ->
    IO CString
-> (CString -> IO ()) -> (CString -> IO String) -> IO String
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (CString -> CString
forall a. Ptr a -> Ptr a
throwNull (CString -> CString) -> IO CString -> IO CString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern_ -> IO CString
fcNameUnparse Pattern_
pat') CString -> IO ()
forall a. Ptr a -> IO ()
free CString -> IO String
peekCString
foreign import ccall "FcNameUnparse" fcNameUnparse :: Pattern_ -> IO CString

-- | Converts given pattern into text described fy given format specifier.
-- See for details: https://www.freedesktop.org/software/fontconfig/fontconfig-devel/fcpatternformat.html
format :: Pattern -> String -> String
format :: Pattern -> ShowS
format pat :: Pattern
pat fmt :: String
fmt =
    IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ Pattern -> (Pattern_ -> IO String) -> IO String
forall a. Pattern -> (Pattern_ -> IO a) -> IO a
withPattern Pattern
pat ((Pattern_ -> IO String) -> IO String)
-> (Pattern_ -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \pat' :: Pattern_
pat' -> String -> (CString -> IO String) -> IO String
forall a. String -> (CString -> IO a) -> IO a
withCString String
fmt ((CString -> IO String) -> IO String)
-> (CString -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \fmt' :: CString
fmt' -> do
        IO CString
-> (CString -> IO ()) -> (CString -> IO String) -> IO String
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (CString -> CString
forall a. Ptr a -> Ptr a
throwNull (CString -> CString) -> IO CString -> IO CString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern_ -> CString -> IO CString
fcPatternFormat Pattern_
pat' CString
fmt') CString -> IO ()
forall a. Ptr a -> IO ()
free CString -> IO String
peekCString
foreign import ccall "FcPatternFormat" fcPatternFormat ::
    Pattern_ -> CString -> IO CString

------
--- Low-level
------

data Pattern'
type Pattern_ = Ptr Pattern'

withPattern :: Pattern -> (Pattern_ -> IO a) -> IO a
withPattern :: Pattern -> (Pattern_ -> IO a) -> IO a
withPattern pat :: Pattern
pat cb :: Pattern_ -> IO a
cb = (Pattern_ -> IO a) -> IO a
forall c. (Pattern_ -> IO c) -> IO c
withNewPattern ((Pattern_ -> IO a) -> IO a) -> (Pattern_ -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \pat' :: Pattern_
pat' -> do
    Pattern
-> ((String, [(Binding, Value)]) -> IO [IO ()]) -> IO [[IO ()]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Pattern
pat (((String, [(Binding, Value)]) -> IO [IO ()]) -> IO [[IO ()]])
-> ((String, [(Binding, Value)]) -> IO [IO ()]) -> IO [[IO ()]]
forall a b. (a -> b) -> a -> b
$ \(obj :: String
obj, vals :: [(Binding, Value)]
vals) -> String -> (CString -> IO [IO ()]) -> IO [IO ()]
forall a. String -> (CString -> IO a) -> IO a
withCString String
obj ((CString -> IO [IO ()]) -> IO [IO ()])
-> (CString -> IO [IO ()]) -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ \obj' :: CString
obj' -> do
        [(Binding, Value)]
-> ((Binding, Value) -> IO (IO ())) -> IO [IO ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Binding, Value)]
vals (((Binding, Value) -> IO (IO ())) -> IO [IO ()])
-> ((Binding, Value) -> IO (IO ())) -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ \(strength :: Binding
strength, val :: Value
val) -> Bool -> IO ()
throwFalse (Bool -> IO ()) -> IO Bool -> IO (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> (Value_ -> IO Bool) -> IO Bool
forall a. Value -> (Value_ -> IO a) -> IO a
withValue Value
val
            (Pattern_ -> CString -> Bool -> Bool -> Value_ -> IO Bool
fcPatternAdd_ Pattern_
pat' CString
obj' (Binding
strength Binding -> Binding -> Bool
forall a. Eq a => a -> a -> Bool
== Binding
Strong) Bool
True)
    Pattern_ -> IO a
cb Pattern_
pat'
-- Does Haskell FFI support unboxed structs? Do I really need to write a C wrapper?
foreign import ccall "my_FcPatternAdd" fcPatternAdd_ ::
    Pattern_ -> CString -> Bool -> Bool -> Value_ -> IO Bool

patternAsPointer :: Pattern -> IO Pattern_
patternAsPointer :: Pattern -> IO Pattern_
patternAsPointer = (Pattern -> (Pattern_ -> IO Pattern_) -> IO Pattern_)
-> (Pattern_ -> IO Pattern_) -> Pattern -> IO Pattern_
forall a b c. (a -> b -> c) -> b -> a -> c
flip Pattern -> (Pattern_ -> IO Pattern_) -> IO Pattern_
forall a. Pattern -> (Pattern_ -> IO a) -> IO a
withPattern ((Pattern_ -> IO Pattern_) -> Pattern -> IO Pattern_)
-> (Pattern_ -> IO Pattern_) -> Pattern -> IO Pattern_
forall a b. (a -> b) -> a -> b
$ \ret :: Pattern_
ret -> do
    Pattern_ -> IO ()
fcPatternReference Pattern_
ret
    Pattern_ -> IO Pattern_
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern_
ret
foreign import ccall "FcPatternReference" fcPatternReference :: Pattern_ -> IO ()

data PatternIter'
type PatternIter_ = Ptr PatternIter'
foreign import ccall "size_PatternIter" patIter'Size :: Int
thawPattern :: Pattern_ -> IO Pattern
thawPattern :: Pattern_ -> IO Pattern
thawPattern pat' :: Pattern_
pat' = Int -> (Ptr PatternIter' -> IO Pattern) -> IO Pattern
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
patIter'Size ((Ptr PatternIter' -> IO Pattern) -> IO Pattern)
-> (Ptr PatternIter' -> IO Pattern) -> IO Pattern
forall a b. (a -> b) -> a -> b
$ \iter' :: Ptr PatternIter'
iter' -> do
    Pattern_ -> Ptr PatternIter' -> IO ()
fcPatternIterStart Pattern_
pat' Ptr PatternIter'
iter'
    Pattern
ret <- Ptr PatternIter' -> IO Pattern
go Ptr PatternIter'
iter'
    Pattern -> IO Pattern
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> IO Pattern) -> Pattern -> IO Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> Pattern
normalizePattern Pattern
ret
  where
    go :: PatternIter_ -> IO Pattern
    go :: Ptr PatternIter' -> IO Pattern
go iter' :: Ptr PatternIter'
iter' = do
        Bool
ok <- Pattern_ -> Ptr PatternIter' -> IO Bool
fcPatternIterIsValid Pattern_
pat' Ptr PatternIter'
iter'
        if Bool
ok then do
            (String, [(Binding, Value)])
x <- Pattern_ -> Ptr PatternIter' -> IO (String, [(Binding, Value)])
thawPattern' Pattern_
pat' Ptr PatternIter'
iter'
            Bool
ok' <- Pattern_ -> Ptr PatternIter' -> IO Bool
fcPatternIterNext Pattern_
pat' Ptr PatternIter'
iter'
            Pattern
xs <- if Bool
ok' then Ptr PatternIter' -> IO Pattern
go Ptr PatternIter'
iter' else Pattern -> IO Pattern
forall (m :: * -> *) a. Monad m => a -> m a
return []
            Pattern -> IO Pattern
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, [(Binding, Value)])
x (String, [(Binding, Value)]) -> Pattern -> Pattern
forall a. a -> [a] -> [a]
: Pattern
xs)
        else Pattern -> IO Pattern
forall (m :: * -> *) a. Monad m => a -> m a
return []
foreign import ccall "FcPatternIterStart" fcPatternIterStart ::
    Pattern_ -> PatternIter_ -> IO ()
foreign import ccall "FcPatternIterIsValid" fcPatternIterIsValid ::
    Pattern_ -> PatternIter_ -> IO Bool
foreign import ccall "FcPatternIterNext" fcPatternIterNext ::
    Pattern_ -> PatternIter_ -> IO Bool

thawPattern' :: Pattern_ -> PatternIter_ -> IO (String, [(Binding, Value)])
thawPattern' :: Pattern_ -> Ptr PatternIter' -> IO (String, [(Binding, Value)])
thawPattern' pat' :: Pattern_
pat' iter' :: Ptr PatternIter'
iter' = do
    String
obj <- CString -> IO String
peekCString (CString -> IO String) -> IO CString -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CString -> CString
forall a. Ptr a -> Ptr a
throwNull (CString -> CString) -> IO CString -> IO CString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern_ -> Ptr PatternIter' -> IO CString
fcPatternIterGetObject Pattern_
pat' Ptr PatternIter'
iter'
    Int
count <- Pattern_ -> Ptr PatternIter' -> IO Int
fcPatternIterValueCount Pattern_
pat' Ptr PatternIter'
iter'
    [Maybe (Maybe (Binding, Value))]
values <- [Int]
-> (Int -> IO (Maybe (Maybe (Binding, Value))))
-> IO [Maybe (Maybe (Binding, Value))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [0..Int -> Int
forall a. Enum a => a -> a
pred Int
count] ((Int -> IO (Maybe (Maybe (Binding, Value))))
 -> IO [Maybe (Maybe (Binding, Value))])
-> (Int -> IO (Maybe (Maybe (Binding, Value))))
-> IO [Maybe (Maybe (Binding, Value))]
forall a b. (a -> b) -> a -> b
$ \i :: Int
i ->
        Int
-> (Value_ -> IO (Maybe (Maybe (Binding, Value))))
-> IO (Maybe (Maybe (Binding, Value)))
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
value'Size ((Value_ -> IO (Maybe (Maybe (Binding, Value))))
 -> IO (Maybe (Maybe (Binding, Value))))
-> (Value_ -> IO (Maybe (Maybe (Binding, Value))))
-> IO (Maybe (Maybe (Binding, Value)))
forall a b. (a -> b) -> a -> b
$ \val' :: Value_
val' -> (Value_ -> IO (Maybe (Maybe (Binding, Value))))
-> IO (Maybe (Maybe (Binding, Value)))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Value_ -> IO (Maybe (Maybe (Binding, Value))))
 -> IO (Maybe (Maybe (Binding, Value))))
-> (Value_ -> IO (Maybe (Maybe (Binding, Value))))
-> IO (Maybe (Maybe (Binding, Value)))
forall a b. (a -> b) -> a -> b
$ \binding' :: Value_
binding' -> do
            Int
res <- Pattern_ -> Ptr PatternIter' -> Int -> Value_ -> Value_ -> IO Int
fcPatternIterGetValue Pattern_
pat' Ptr PatternIter'
iter' Int
i Value_
val' Value_
binding'
            Int
-> IO (Maybe (Binding, Value))
-> IO (Maybe (Maybe (Binding, Value)))
forall a. Int -> IO a -> IO (Maybe a)
throwInt Int
res (IO (Maybe (Binding, Value))
 -> IO (Maybe (Maybe (Binding, Value))))
-> IO (Maybe (Binding, Value))
-> IO (Maybe (Maybe (Binding, Value)))
forall a b. (a -> b) -> a -> b
$ do
                Int
binding <- Value_ -> IO Int
forall a. Storable a => Ptr a -> IO a
peek Value_
binding'
                Maybe Value
val' <- Value_ -> IO (Maybe Value)
thawValue Value_
val'
                Maybe (Binding, Value) -> IO (Maybe (Binding, Value))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Binding, Value) -> IO (Maybe (Binding, Value)))
-> Maybe (Binding, Value) -> IO (Maybe (Binding, Value))
forall a b. (a -> b) -> a -> b
$ case Maybe Value
val' of
                    Just val :: Value
val | Int
binding Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 Bool -> Bool -> Bool
&& Int
binding Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 2 -> (Binding, Value) -> Maybe (Binding, Value)
forall a. a -> Maybe a
Just (Int -> Binding
forall a. Enum a => Int -> a
toEnum Int
binding, Value
val)
                    Just val :: Value
val -> (Binding, Value) -> Maybe (Binding, Value)
forall a. a -> Maybe a
Just (Binding
Same, Value
val)
                    Nothing -> Maybe (Binding, Value)
forall a. Maybe a
Nothing
    (String, [(Binding, Value)]) -> IO (String, [(Binding, Value)])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
obj, [Maybe (Binding, Value)] -> [(Binding, Value)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Binding, Value)] -> [(Binding, Value)])
-> [Maybe (Binding, Value)] -> [(Binding, Value)]
forall a b. (a -> b) -> a -> b
$ (Maybe (Maybe (Binding, Value)) -> Maybe (Binding, Value))
-> [Maybe (Maybe (Binding, Value))] -> [Maybe (Binding, Value)]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (Maybe (Binding, Value)) -> Maybe (Binding, Value)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [Maybe (Maybe (Binding, Value))]
values)
foreign import ccall "FcPatternIterGetObject" fcPatternIterGetObject ::
    Pattern_ -> PatternIter_ -> IO CString
foreign import ccall "FcPatternIterValueCount" fcPatternIterValueCount ::
    Pattern_ -> PatternIter_ -> IO Int
foreign import ccall "FcPatternIterGetValue" fcPatternIterGetValue ::
    Pattern_ -> PatternIter_ -> Int -> Value_ -> Ptr Int -> IO Int

thawPattern_ :: IO Pattern_ -> IO Pattern
thawPattern_ cb :: IO Pattern_
cb = IO Pattern_
-> (Pattern_ -> IO ()) -> (Pattern_ -> IO Pattern) -> IO Pattern
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Pattern_ -> Pattern_
forall a. Ptr a -> Ptr a
throwNull (Pattern_ -> Pattern_) -> IO Pattern_ -> IO Pattern_
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Pattern_
cb) Pattern_ -> IO ()
fcPatternDestroy Pattern_ -> IO Pattern
thawPattern

withNewPattern :: (Pattern_ -> IO c) -> IO c
withNewPattern cb :: Pattern_ -> IO c
cb = IO Pattern_ -> (Pattern_ -> IO ()) -> (Pattern_ -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Pattern_ -> Pattern_
forall a. Ptr a -> Ptr a
throwNull (Pattern_ -> Pattern_) -> IO Pattern_ -> IO Pattern_
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Pattern_
fcPatternCreate) Pattern_ -> IO ()
fcPatternDestroy Pattern_ -> IO c
cb
foreign import ccall "FcPatternCreate" fcPatternCreate :: IO Pattern_
foreign import ccall "FcPatternDestroy" fcPatternDestroy :: Pattern_ -> IO ()

------
--- Pattern
------

parseFontFamily :: [Token] -> ([String], Bool, [Token])
parseFontFamily :: [Token] -> ([String], Bool, [Token])
parseFontFamily (String font :: Text
font:Comma:tail :: [Token]
tail) = let (fonts :: [String]
fonts, b :: Bool
b, tail' :: [Token]
tail') = [Token] -> ([String], Bool, [Token])
parseFontFamily [Token]
tail
    in (Text -> String
unpack Text
fontString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
fonts, Bool
b, [Token]
tail')
parseFontFamily (Ident font :: Text
font:Comma:tail :: [Token]
tail) = let (fonts :: [String]
fonts, b :: Bool
b, tail' :: [Token]
tail') = [Token] -> ([String], Bool, [Token])
parseFontFamily [Token]
tail
    in (Text -> String
unpack Text
fontString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
fonts, Bool
b, [Token]
tail')
parseFontFamily (String font :: Text
font:tail :: [Token]
tail) = ([Text -> String
unpack Text
font], Bool
True, [Token]
tail)
parseFontFamily (Ident font :: Text
font:tail :: [Token]
tail) = ([Text -> String
unpack Text
font], Bool
True, [Token]
tail)
parseFontFamily toks :: [Token]
toks = ([], Bool
False, [Token]
toks) -- Invalid syntax!

parseFontFeatures :: [Token] -> ([(String, Int)], Bool, [Token])
parseFontFeatures :: [Token] -> ([(String, Int)], Bool, [Token])
parseFontFeatures (String feat :: Text
feat:toks :: [Token]
toks) | feature :: String
feature@(_:_:_:_:[]) <- Text -> String
unpack Text
feat = case [Token]
toks of
    Comma:tail :: [Token]
tail -> let (feats :: [(String, Int)]
feats, b :: Bool
b, tail' :: [Token]
tail') = [Token] -> ([(String, Int)], Bool, [Token])
parseFontFeatures [Token]
tail in ((String
feature, 1)(String, Int) -> [(String, Int)] -> [(String, Int)]
forall a. a -> [a] -> [a]
:[(String, Int)]
feats, Bool
b, [Token]
tail')
    Ident "on":Comma:tail :: [Token]
tail -> let (f :: [(String, Int)]
f, b :: Bool
b, t :: [Token]
t) = [Token] -> ([(String, Int)], Bool, [Token])
parseFontFeatures [Token]
tail in ((String
feature, 1)(String, Int) -> [(String, Int)] -> [(String, Int)]
forall a. a -> [a] -> [a]
:[(String, Int)]
f, Bool
b, [Token]
t)
    Ident "on":tail :: [Token]
tail -> ([(String
feature, 1)], Bool
True, [Token]
tail)
    Ident "off":Comma:tail :: [Token]
tail -> let (f :: [(String, Int)]
f, b :: Bool
b, t :: [Token]
t) = [Token] -> ([(String, Int)], Bool, [Token])
parseFontFeatures [Token]
tail in ((String
feature, 1)(String, Int) -> [(String, Int)] -> [(String, Int)]
forall a. a -> [a] -> [a]
:[(String, Int)]
f, Bool
b, [Token]
t)
    Ident "off":tail :: [Token]
tail -> ([(String
feature, 1)], Bool
True, [Token]
tail)
    Number _ (NVInteger x :: Integer
x):Comma:tail :: [Token]
tail ->
        let (feats :: [(String, Int)]
feats, b :: Bool
b, tail' :: [Token]
tail') = [Token] -> ([(String, Int)], Bool, [Token])
parseFontFeatures [Token]
tail in ((String
feature, Integer -> Int
forall a. Enum a => a -> Int
fromEnum Integer
x)(String, Int) -> [(String, Int)] -> [(String, Int)]
forall a. a -> [a] -> [a]
:[(String, Int)]
feats, Bool
b, [Token]
tail')
    Number _ (NVInteger x :: Integer
x):tail :: [Token]
tail -> ([(String
feature, Integer -> Int
forall a. Enum a => a -> Int
fromEnum Integer
x)], Bool
True, [Token]
tail)
parseFontFeatures toks :: [Token]
toks = ([], Bool
False, [Token]
toks)

parseFontVars :: [Token] -> ([(String, Double)], Bool, [Token])
parseFontVars :: [Token] -> ([(String, Double)], Bool, [Token])
parseFontVars (String var' :: Text
var':Number _ x :: NumericValue
x:Comma:tail :: [Token]
tail) | var :: String
var@(_:_:_:_:[]) <- Text -> String
unpack Text
var' =
    let (vars :: [(String, Double)]
vars, b :: Bool
b, tail' :: [Token]
tail') = [Token] -> ([(String, Double)], Bool, [Token])
parseFontVars [Token]
tail in ((String
var, NumericValue -> Double
forall p. RealFloat p => NumericValue -> p
nv2double NumericValue
x)(String, Double) -> [(String, Double)] -> [(String, Double)]
forall a. a -> [a] -> [a]
:[(String, Double)]
vars, Bool
b, [Token]
tail')
parseFontVars (String var' :: Text
var':Number _ x :: NumericValue
x:tail :: [Token]
tail) | var :: String
var@(_:_:_:_:[]) <- Text -> String
unpack Text
var' =
    ([(String
var, NumericValue -> Double
forall p. RealFloat p => NumericValue -> p
nv2double NumericValue
x)], Bool
True, [Token]
tail)
parseFontVars toks :: [Token]
toks = ([], Bool
False, [Token]
toks)

parseLength :: Double -> NumericValue -> Text -> Double
parseLength :: Double -> NumericValue -> Text -> Double
parseLength super :: Double
super length :: NumericValue
length unit :: Text
unit = Double -> Text -> Double
convert (NumericValue -> Double
forall p. RealFloat p => NumericValue -> p
nv2double NumericValue
length) Text
unit
  where
    convert :: Double -> Text -> Double
convert = Double -> Text -> Double
forall t. (Eq t, IsString t) => Double -> t -> Double
c
    c :: Double -> t -> Double
c x :: Double
x "pt" = Double
x -- Unit FontConfig expects!
    c x :: Double
x "pc" = Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/6 Double -> t -> Double
`c` "in"
    c x :: Double
x "in" = Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/72 Double -> t -> Double
`c` "pt"
    c x :: Double
x "Q" = Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/40 Double -> t -> Double
`c` "cm"
    c x :: Double
x "mm" = Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/10 Double -> t -> Double
`c` "cm"
    c x :: Double
x "cm" = Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/2.54 Double -> t -> Double
`c` "in"
    c x :: Double
x "px" = Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/96 Double -> t -> Double
`c` "in" -- Conversion factor during early days of CSS, got entrenched.
    c x :: Double
x "em" = Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
super
    c x :: Double
x "%" = Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/100 Double -> t -> Double
`c` "em"
    c _ _ = 0Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0 -- NaN

parseFontStretch :: Token -> Maybe Int -- Result in percentages
parseFontStretch :: Token -> Maybe Int
parseFontStretch (Percentage _ x :: NumericValue
x) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall a. Enum a => a -> Int
fromEnum (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ NumericValue -> Double
forall p. RealFloat p => NumericValue -> p
nv2double NumericValue
x
parseFontStretch (Ident "ultra-condensed") = Int -> Maybe Int
forall a. a -> Maybe a
Just 50
parseFontStretch (Ident "extra-condensed") = Int -> Maybe Int
forall a. a -> Maybe a
Just 63 -- 62.5%, but round towards 100%
parseFontStretch (Ident "condensed") = Int -> Maybe Int
forall a. a -> Maybe a
Just 75
parseFontStretch (Ident "semi-condensed") = Int -> Maybe Int
forall a. a -> Maybe a
Just 88 -- 87.5% actually...
parseFontStretch (Ident "normal") = Int -> Maybe Int
forall a. a -> Maybe a
Just 100
parseFontStretch (Ident "initial") = Int -> Maybe Int
forall a. a -> Maybe a
Just 100
parseFontStretch (Ident "semi-expanded") = Int -> Maybe Int
forall a. a -> Maybe a
Just 112 -- 112.5% actually...
parseFontStretch (Ident "expanded") = Int -> Maybe Int
forall a. a -> Maybe a
Just 125
parseFontStretch (Ident "extra-expanded") = Int -> Maybe Int
forall a. a -> Maybe a
Just 150
parseFontStretch (Ident "ultra-expanded") = Int -> Maybe Int
forall a. a -> Maybe a
Just 200
parseFontStretch _ = Maybe Int
forall a. Maybe a
Nothing

-- Conversion between CSS scale & FontConfig scale is non-trivial, use lookuptable.
parseFontWeight :: Token -> Maybe Int
parseFontWeight :: Token -> Maybe Int
parseFontWeight (Ident k :: Text
k) | Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["initial", "normal"] = Int -> Maybe Int
forall a. a -> Maybe a
Just 80
parseFontWeight (Ident "bold") = Int -> Maybe Int
forall a. a -> Maybe a
Just 200
parseFontWeight (Number _ (NVInteger x :: Integer
x)) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
weightFromOpenType (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Enum a => a -> Int
fromEnum Integer
x
parseFontWeight _ = Maybe Int
forall a. Maybe a
Nothing

nv2double :: NumericValue -> p
nv2double (NVInteger x :: Integer
x) = Integer -> p
forall a. Num a => Integer -> a
fromInteger Integer
x
nv2double (NVNumber x :: Scientific
x) = Scientific -> p
forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
x

sets :: String -> Binding -> [x] -> Pattern -> Maybe Pattern
sets a :: String
a b :: Binding
b c :: [x]
c d :: Pattern
d = Pattern -> Maybe Pattern
forall a. a -> Maybe a
Just (Pattern -> Maybe Pattern) -> Pattern -> Maybe Pattern
forall a b. (a -> b) -> a -> b
$ String -> Binding -> [x] -> Pattern -> Pattern
forall x.
ToValue x =>
String -> Binding -> [x] -> Pattern -> Pattern
setValues String
a Binding
b [x]
c Pattern
d
set :: String -> Binding -> x -> Pattern -> Maybe Pattern
set a :: String
a b :: Binding
b c :: x
c d :: Pattern
d = Pattern -> Maybe Pattern
forall a. a -> Maybe a
Just (Pattern -> Maybe Pattern) -> Pattern -> Maybe Pattern
forall a b. (a -> b) -> a -> b
$ String -> Binding -> x -> Pattern -> Pattern
forall x. ToValue x => String -> Binding -> x -> Pattern -> Pattern
setValue String
a Binding
b x
c Pattern
d
seti :: String -> Binding -> Int -> Pattern -> Maybe Pattern
seti a :: String
a b :: Binding
b c :: Int
c d :: Pattern
d = Pattern -> Maybe Pattern
forall a. a -> Maybe a
Just (Pattern -> Maybe Pattern) -> Pattern -> Maybe Pattern
forall a b. (a -> b) -> a -> b
$ String -> Binding -> Int -> Pattern -> Pattern
forall x. ToValue x => String -> Binding -> x -> Pattern -> Pattern
setValue String
a Binding
b (Int
c :: Int) Pattern
d
unset' :: a -> [(a, b)] -> Maybe [(a, b)]
unset' a :: a
a b :: [(a, b)]
b = [(a, b)] -> Maybe [(a, b)]
forall a. a -> Maybe a
Just ([(a, b)] -> Maybe [(a, b)]) -> [(a, b)] -> Maybe [(a, b)]
forall a b. (a -> b) -> a -> b
$ a -> [(a, b)] -> [(a, b)]
forall a b. Eq a => a -> [(a, b)] -> [(a, b)]
unset a
a [(a, b)]
b

getSize :: Pattern -> Double
getSize pat :: Pattern
pat | ValueDouble x :: Double
x <- String -> Pattern -> Value
getValue "size" Pattern
pat = Double
x
    | Bool
otherwise = 10

instance PropertyParser Pattern where
    temp :: Pattern
temp = []

    longhand :: Pattern -> Pattern -> Text -> [Token] -> Maybe Pattern
longhand _ self :: Pattern
self "font-family" toks :: [Token]
toks
        | (fonts :: [String]
fonts, True, []) <- [Token] -> ([String], Bool, [Token])
parseFontFamily [Token]
toks = String -> Binding -> [String] -> Pattern -> Maybe Pattern
forall x.
ToValue x =>
String -> Binding -> [x] -> Pattern -> Maybe Pattern
sets "family" Binding
Strong [String]
fonts Pattern
self

    -- font-size: initial should be configurable!
    longhand super :: Pattern
super self :: Pattern
self "font-size" [Dimension _ x :: NumericValue
x unit :: Text
unit]
        | let y :: Double
y = Double -> NumericValue -> Text -> Double
parseLength (Pattern -> Double
getSize Pattern
super) NumericValue
x Text
unit, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
y =
            String -> Binding -> Double -> Pattern -> Maybe Pattern
forall x.
ToValue x =>
String -> Binding -> x -> Pattern -> Maybe Pattern
set "size" Binding
Strong Double
y Pattern
self
    longhand super :: Pattern
super self :: Pattern
self "font-size" [Percentage x :: Text
x y :: NumericValue
y] =
        Pattern -> Pattern -> Text -> [Token] -> Maybe Pattern
forall a. PropertyParser a => a -> a -> Text -> [Token] -> Maybe a
longhand Pattern
super Pattern
self "font-size" [Text -> NumericValue -> Text -> Token
Dimension Text
x NumericValue
y "%"]

    longhand _ self :: Pattern
self "font-style" [Ident "initial"] = String -> Binding -> Int -> Pattern -> Maybe Pattern
seti "slant" Binding
Strong 0 Pattern
self
    longhand _ self :: Pattern
self "font-style" [Ident "normal"] = String -> Binding -> Int -> Pattern -> Maybe Pattern
seti "slant" Binding
Strong 0 Pattern
self
    longhand _ self :: Pattern
self "font-style" [Ident "italic"] = String -> Binding -> Int -> Pattern -> Maybe Pattern
seti "slant" Binding
Strong 100 Pattern
self
    longhand _ self :: Pattern
self "font-style" [Ident "oblique"] = String -> Binding -> Int -> Pattern -> Maybe Pattern
seti "slant" Binding
Strong 110 Pattern
self

    -- Conversion between CSS scale & FontConfig scale is non-trivial, use lookuptable.
    longhand _ self :: Pattern
self "font-weight" [tok :: Token
tok]
        | Just x :: Int
x <- Token -> Maybe Int
parseFontWeight Token
tok = String -> Binding -> Int -> Pattern -> Maybe Pattern
seti "weight" Binding
Strong Int
x Pattern
self
    longhand super :: Pattern
super self :: Pattern
self "font-weight" [Number _ (NVInteger x :: Integer
x)]
        | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 920 = Pattern -> Pattern -> Text -> [Token] -> Maybe Pattern
forall a. PropertyParser a => a -> a -> Text -> [Token] -> Maybe a
longhand Pattern
super Pattern
self "font-weight" [Text -> NumericValue -> Token
Number "" (NumericValue -> Token) -> NumericValue -> Token
forall a b. (a -> b) -> a -> b
$ Integer -> NumericValue
NVInteger 950]
        | Bool
otherwise = Pattern -> Pattern -> Text -> [Token] -> Maybe Pattern
forall a. PropertyParser a => a -> a -> Text -> [Token] -> Maybe a
longhand Pattern
super Pattern
self "font-weight" [Text -> NumericValue -> Token
Number "" (NumericValue -> Token) -> NumericValue -> Token
forall a b. (a -> b) -> a -> b
$ Integer -> NumericValue
NVInteger (Integer -> NumericValue) -> Integer -> NumericValue
forall a b. (a -> b) -> a -> b
$ (Integer
x Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` 100) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 100]
    longhand _ self :: Pattern
self "font-weight" [Ident "lighter"]
        | ValueInt x :: Int
x <- String -> Pattern -> Value
getValue "weight" Pattern
self, Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 200 = String -> Binding -> Int -> Pattern -> Maybe Pattern
seti "weight" Binding
Strong 200 Pattern
self
        -- minus 100 adhears to the CSS standard awefully well in this new scale.
        | ValueInt x :: Int
x <- String -> Pattern -> Value
getValue "weight" Pattern
self = String -> Binding -> Int -> Pattern -> Maybe Pattern
seti "weight" Binding
Strong (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- 100) 0) Pattern
self
        | Bool
otherwise = String -> Binding -> Int -> Pattern -> Maybe Pattern
seti "weight" Binding
Strong 0 Pattern
self
    longhand _ self :: Pattern
self "font-weight" [Ident "bolder"]
        | ValueInt x :: Int
x <- String -> Pattern -> Value
getValue "weight" Pattern
self, Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 65 = String -> Binding -> Int -> Pattern -> Maybe Pattern
seti "weight" Binding
Strong 80 Pattern
self
        | ValueInt x :: Int
x <- String -> Pattern -> Value
getValue "weight" Pattern
self, Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 150 = String -> Binding -> Int -> Pattern -> Maybe Pattern
seti "weight" Binding
Strong 200 Pattern
self
        | ValueInt x :: Int
x <- String -> Pattern -> Value
getValue "weight" Pattern
self, Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 210 = String -> Binding -> Int -> Pattern -> Maybe Pattern
seti "weight" Binding
Strong 210 Pattern
self
        | ValueInt _ <- String -> Pattern -> Value
getValue "weight" Pattern
self = Pattern -> Maybe Pattern
forall a. a -> Maybe a
Just Pattern
self -- As bold as it goes...
        | Bool
otherwise = String -> Binding -> Int -> Pattern -> Maybe Pattern
seti "weight" Binding
Strong 200 Pattern
self

    longhand _ self :: Pattern
self "font-feature-settings" [Ident k :: Text
k]
        | Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["initial", "normal"] = String -> Pattern -> Maybe Pattern
forall a b. Eq a => a -> [(a, b)] -> Maybe [(a, b)]
unset' "fontfeatures" Pattern
self
    longhand _ self :: Pattern
self "font-feature-settings" toks :: [Token]
toks
        | (features :: [(String, Int)]
features, True, []) <- [Token] -> ([(String, Int)], Bool, [Token])
parseFontFeatures [Token]
toks =
            String -> Binding -> String -> Pattern -> Maybe Pattern
forall x.
ToValue x =>
String -> Binding -> x -> Pattern -> Maybe Pattern
set "fontfeatures" Binding
Strong (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((String, Int) -> String) -> [(String, Int)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Int) -> String
forall a b. (a, b) -> a
fst [(String, Int)]
features) Pattern
self

    longhand _ self :: Pattern
self "font-variation-settings" [Ident k :: Text
k]
        | Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["initial", "normal"] = String -> Pattern -> Maybe Pattern
forall a b. Eq a => a -> [(a, b)] -> Maybe [(a, b)]
unset' "variable" Pattern
self
    longhand _ self :: Pattern
self "font-variation-settings" toks :: [Token]
toks
        | (_, True, []) <- [Token] -> ([(String, Double)], Bool, [Token])
parseFontVars [Token]
toks = String -> Binding -> Bool -> Pattern -> Maybe Pattern
forall x.
ToValue x =>
String -> Binding -> x -> Pattern -> Maybe Pattern
set "variable" Binding
Strong Bool
True Pattern
self

    longhand _ s :: Pattern
s "font-stretch" [tok :: Token
tok]
        | Just x :: Int
x <- Token -> Maybe Int
parseFontStretch Token
tok = String -> Binding -> Int -> Pattern -> Maybe Pattern
seti "width" Binding
Strong Int
x Pattern
s

    longhand _ _ _ _ = Maybe Pattern
forall a. Maybe a
Nothing