{-# 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
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' = forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
patIter'Size forall a b. (a -> b) -> a -> b
$ \Ptr PatternIter'
iter' -> do
    Pattern_ -> Ptr PatternIter' -> IO ()
fcPatternIterStart Pattern_
pat' Ptr PatternIter'
iter'
    Pattern
ret <- Ptr PatternIter' -> IO Pattern
go Ptr 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 :: PatternIter_ -> IO Pattern
    go :: Ptr PatternIter' -> IO Pattern
go 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 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 []
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' Pattern_
pat' Ptr 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_ -> 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 <- 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_ -> Ptr PatternIter' -> Int -> Value_ -> Value_ -> IO Int
fcPatternIterGetValue Pattern_
pat' Ptr 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 ()

------
--- 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