{-# 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,
    fcPatternReference,

    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, FunPtr)
import Foreign.ForeignPtr (ForeignPtr,
        newForeignPtr, withForeignPtr, mallocForeignPtrBytes)
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, unsafeInterleaveIO)

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
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
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
Ord, Int -> Binding
Binding -> Int
Binding -> [Binding]
Binding -> Binding
Binding -> Binding -> [Binding]
Binding -> Binding -> Binding -> [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
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. 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 Binding
Strong = Int
0
    hash Binding
Weak = Int
1
    hash Binding
Same = Int
2

-- | Replaces the values under the given "key" in given "pattern"
-- with given "binding" & "value".
setValue :: ToValue x => String -> Binding -> x -> Pattern -> Pattern
setValue :: forall x. ToValue x => String -> Binding -> x -> Pattern -> Pattern
setValue String
key Binding
b x
value Pattern
pat = (String
key, [(Binding
b, forall x. ToValue x => x -> Value
toValue x
value)])forall a. a -> [a] -> [a]
: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 :: forall x.
ToValue x =>
String -> Binding -> [x] -> Pattern -> Pattern
setValues String
key Binding
b [x]
values Pattern
pat = (String
key, [(Binding
b, forall x. ToValue x => x -> Value
toValue x
v) | x
v <- [x]
values])forall a. a -> [a] -> [a]
: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 String
key Pattern
pat | Just [(Binding, Value)]
ret <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
key Pattern
pat = forall a b. (a -> b) -> [a] -> [b]
map 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' String
key Pattern
pat = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall x. ToValue x => Value -> Maybe x
fromValue 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 String
key Pattern
pat | Just ((Binding
_, Value
ret):[(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' :: forall x. ToValue x => String -> Pattern -> Maybe x
getValue' String
key Pattern
pat = forall x. ToValue x => Value -> Maybe x
fromValue 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 :: forall x. ToValue x => String -> Pattern -> x
getValue0 String
key Pattern
pat = forall x. ToValue x => Value -> x
fromValue' 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 a
key [(a, b)]
mapping = [(a
key', b
val') | (a
key', b
val') <- [(a, b)]
mapping, a
key' 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 Pattern
pat =
    [(String
key, [(Binding, Value)
val | (String
key', [(Binding, Value)]
vals) <- Pattern
pat, String
key' forall a. Eq a => a -> a -> Bool
== String
key, (Binding, Value)
val <- [(Binding, Value)]
vals]) | String
key <- forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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 Pattern
a Pattern
b [String]
objs = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. Pattern -> (Pattern_ -> IO a) -> IO a
withPattern Pattern
a forall a b. (a -> b) -> a -> b
$ \Pattern_
a' -> forall a. Pattern -> (Pattern_ -> IO a) -> IO a
withPattern Pattern
b forall a b. (a -> b) -> a -> b
$ \Pattern_
b' ->
    forall a. [String] -> (ObjectSet_ -> IO a) -> IO a
withObjectSet [String]
objs 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 Pattern
pat [String]
objs =
    forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. Pattern -> (Pattern_ -> IO a) -> IO a
withPattern Pattern
pat forall a b. (a -> b) -> a -> b
$ \Pattern_
pat' -> forall a. [String] -> (ObjectSet_ -> IO a) -> IO a
withObjectSet [String]
objs forall a b. (a -> b) -> a -> b
$ \ObjectSet_
objs' ->
        IO Pattern_ -> IO Pattern
thawPattern_ 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 Pattern
pat = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. Pattern -> (Pattern_ -> IO a) -> IO a
withPattern Pattern
pat forall a b. (a -> b) -> a -> b
$ \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 String
name = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. String -> (CString -> IO a) -> IO a
withCString String
name forall a b. (a -> b) -> a -> b
$ \CString
name' ->
    IO Pattern_ -> IO Pattern
thawPattern_ 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 Pattern
pat = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. Pattern -> (Pattern_ -> IO a) -> IO a
withPattern Pattern
pat forall a b. (a -> b) -> a -> b
$ \Pattern_
pat' ->
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall a. Ptr a -> Ptr a
throwNull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern_ -> IO CString
fcNameUnparse Pattern_
pat') 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 Pattern
pat String
fmt =
    forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. Pattern -> (Pattern_ -> IO a) -> IO a
withPattern Pattern
pat forall a b. (a -> b) -> a -> b
$ \Pattern_
pat' -> forall a. String -> (CString -> IO a) -> IO a
withCString String
fmt forall a b. (a -> b) -> a -> b
$ \CString
fmt' -> do
        forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall a. Ptr a -> Ptr a
throwNull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern_ -> CString -> IO CString
fcPatternFormat Pattern_
pat' CString
fmt') 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 :: forall a. Pattern -> (Pattern_ -> IO a) -> IO a
withPattern Pattern
pat Pattern_ -> IO a
cb = forall {c}. (Pattern_ -> IO c) -> IO c
withNewPattern forall a b. (a -> b) -> a -> b
$ \Pattern_
pat' -> do
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Pattern
pat forall a b. (a -> b) -> a -> b
$ \(String
obj, [(Binding, Value)]
vals) -> forall a. String -> (CString -> IO a) -> IO a
withCString String
obj forall a b. (a -> b) -> a -> b
$ \CString
obj' -> do
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Binding, Value)]
vals forall a b. (a -> b) -> a -> b
$ \(Binding
strength, Value
val) -> Bool -> IO ()
throwFalse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Pattern -> (Pattern_ -> IO a) -> IO a
withPattern forall a b. (a -> b) -> a -> b
$ \Pattern_
ret -> do
    Pattern_ -> IO ()
fcPatternReference Pattern_
ret
    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 Pattern_
pat' = do
    ForeignPtr PatternIter'
iter <- forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
patIter'Size
    ForeignPtr Pattern'
pat <- Pattern_ -> IO (ForeignPtr Pattern')
gcPattern Pattern_
pat'
    forall {a} {a} {b}.
ForeignPtr a -> ForeignPtr a -> (Ptr a -> Ptr a -> IO b) -> IO b
with2ForeignPtrs ForeignPtr Pattern'
pat ForeignPtr PatternIter'
iter Pattern_ -> PatternIter_ -> IO ()
fcPatternIterStart
    Pattern
ret <- ForeignPtr Pattern' -> ForeignPtr PatternIter' -> IO Pattern
go ForeignPtr Pattern'
pat ForeignPtr PatternIter'
iter
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pattern -> Pattern
normalizePattern Pattern
ret
  where
    go :: ForeignPtr Pattern' -> ForeignPtr PatternIter' -> IO Pattern
    go :: ForeignPtr Pattern' -> ForeignPtr PatternIter' -> IO Pattern
go ForeignPtr Pattern'
pat ForeignPtr PatternIter'
iter = forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ do
        Bool
ok <- forall {a} {a} {b}.
ForeignPtr a -> ForeignPtr a -> (Ptr a -> Ptr a -> IO b) -> IO b
with2ForeignPtrs ForeignPtr Pattern'
pat ForeignPtr PatternIter'
iter Pattern_ -> PatternIter_ -> IO Bool
fcPatternIterIsValid
        if Bool
ok then do
            (String, [(Binding, Value)])
x <- forall {a} {a} {b}.
ForeignPtr a -> ForeignPtr a -> (Ptr a -> Ptr a -> IO b) -> IO b
with2ForeignPtrs ForeignPtr Pattern'
pat ForeignPtr PatternIter'
iter Pattern_ -> PatternIter_ -> IO (String, [(Binding, Value)])
thawPattern'
            Bool
ok' <- forall {a} {a} {b}.
ForeignPtr a -> ForeignPtr a -> (Ptr a -> Ptr a -> IO b) -> IO b
with2ForeignPtrs ForeignPtr Pattern'
pat ForeignPtr PatternIter'
iter Pattern_ -> PatternIter_ -> IO Bool
fcPatternIterNext
            Pattern
xs <- if Bool
ok' then ForeignPtr Pattern' -> ForeignPtr PatternIter' -> IO Pattern
go ForeignPtr Pattern'
pat ForeignPtr PatternIter'
iter else forall (m :: * -> *) a. Monad m => a -> m a
return []
            forall (m :: * -> *) a. Monad m => a -> m a
return ((String, [(Binding, Value)])
x forall a. a -> [a] -> [a]
: Pattern
xs)
        else forall (m :: * -> *) a. Monad m => a -> m a
return []
    with2ForeignPtrs :: ForeignPtr a -> ForeignPtr a -> (Ptr a -> Ptr a -> IO b) -> IO b
with2ForeignPtrs ForeignPtr a
a ForeignPtr a
b Ptr a -> Ptr a -> IO b
cb = forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr a
a forall a b. (a -> b) -> a -> b
$ \Ptr a
a' -> forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr a
b forall a b. (a -> b) -> a -> b
$ Ptr a -> Ptr a -> IO b
cb Ptr a
a'
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_ -> PatternIter_ -> IO (String, [(Binding, Value)])
thawPattern' Pattern_
pat' PatternIter_
iter' = do
    String
obj <- CString -> IO String
peekCString forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Ptr a -> Ptr a
throwNull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern_ -> PatternIter_ -> IO CString
fcPatternIterGetObject Pattern_
pat' PatternIter_
iter'
    Int
count <- Pattern_ -> PatternIter_ -> IO Int
fcPatternIterValueCount Pattern_
pat' PatternIter_
iter'
    [Maybe (Maybe (Binding, Value))]
values <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0..forall a. Enum a => a -> a
pred Int
count] forall a b. (a -> b) -> a -> b
$ \Int
i ->
        forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
value'Size forall a b. (a -> b) -> a -> b
$ \Value_
val' -> forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Value_
binding' -> do
            Int
res <- Pattern_ -> PatternIter_ -> Int -> Value_ -> Value_ -> IO Int
fcPatternIterGetValue Pattern_
pat' PatternIter_
iter' Int
i Value_
val' Value_
binding'
            forall a. Int -> IO a -> IO (Maybe a)
throwInt Int
res forall a b. (a -> b) -> a -> b
$ do
                Int
binding <- forall a. Storable a => Ptr a -> IO a
peek Value_
binding'
                Maybe Value
val' <- Value_ -> IO (Maybe Value)
thawValue Value_
val'
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe Value
val' of
                    Just Value
val | Int
binding forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
binding forall a. Ord a => a -> a -> Bool
<= Int
2 -> forall a. a -> Maybe a
Just (forall a. Enum a => Int -> a
toEnum Int
binding, Value
val)
                    Just Value
val -> forall a. a -> Maybe a
Just (Binding
Same, Value
val)
                    Maybe Value
Nothing -> forall a. Maybe a
Nothing
    forall (m :: * -> *) a. Monad m => a -> m a
return (String
obj, forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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_ IO Pattern_
cb = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall a. Ptr a -> Ptr a
throwNull 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 Pattern_ -> IO c
cb = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall a. Ptr a -> Ptr a
throwNull 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 ()
foreign import ccall "&FcPatternDestroy" fcPatternDestroy' ::
    FunPtr (Pattern_ -> IO ())

gcPattern :: Pattern_ -> IO (ForeignPtr Pattern')
gcPattern :: Pattern_ -> IO (ForeignPtr Pattern')
gcPattern Pattern_
pat' = do
    Pattern_ -> IO ()
fcPatternReference Pattern_
pat'
    forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FunPtr (Pattern_ -> IO ())
fcPatternDestroy' Pattern_
pat'

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

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

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

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

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

parseFontStretch :: Token -> Maybe Int -- Result in percentages
parseFontStretch :: Token -> Maybe Int
parseFontStretch (Percentage Text
_ NumericValue
x) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ forall {a}. RealFloat a => NumericValue -> a
nv2double NumericValue
x
parseFontStretch (Ident Text
"ultra-condensed") = forall a. a -> Maybe a
Just Int
50
parseFontStretch (Ident Text
"extra-condensed") = forall a. a -> Maybe a
Just Int
63 -- 62.5%, but round towards 100%
parseFontStretch (Ident Text
"condensed") = forall a. a -> Maybe a
Just Int
75
parseFontStretch (Ident Text
"semi-condensed") = forall a. a -> Maybe a
Just Int
88 -- 87.5% actually...
parseFontStretch (Ident Text
"normal") = forall a. a -> Maybe a
Just Int
100
parseFontStretch (Ident Text
"initial") = forall a. a -> Maybe a
Just Int
100
parseFontStretch (Ident Text
"semi-expanded") = forall a. a -> Maybe a
Just Int
112 -- 112.5% actually...
parseFontStretch (Ident Text
"expanded") = forall a. a -> Maybe a
Just Int
125
parseFontStretch (Ident Text
"extra-expanded") = forall a. a -> Maybe a
Just Int
150
parseFontStretch (Ident Text
"ultra-expanded") = forall a. a -> Maybe a
Just Int
200
parseFontStretch Token
_ = 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 Text
k) | Text
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"initial", Text
"normal"] = forall a. a -> Maybe a
Just Int
80
parseFontWeight (Ident Text
"bold") = forall a. a -> Maybe a
Just Int
200
parseFontWeight (Number Text
_ (NVInteger Integer
x)) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Int
weightFromOpenType forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum Integer
x
parseFontWeight Token
_ = forall a. Maybe a
Nothing

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

sets :: String -> Binding -> [x] -> Pattern -> Maybe Pattern
sets String
a Binding
b [x]
c Pattern
d = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 String
a Binding
b x
c Pattern
d = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 String
a Binding
b Int
c Pattern
d = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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)]
b = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall {a} {b}. Eq a => a -> [(a, b)] -> [(a, b)]
unset a
a [(a, b)]
b

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

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

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

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

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

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

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

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

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

    longhand Pattern
_ Pattern
_ Text
_ [Token]
_ = forall a. Maybe a
Nothing