{-# 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)
import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO)
import Control.Monad (forM, join)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Control.Exception (bracket)
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)
type Pattern = [(String, [(Binding, Value)])]
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
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
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
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 = []
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
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
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
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
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]
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]
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
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_
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 ()
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_
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
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
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'
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'
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)
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
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"
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
parseFontStretch :: Token -> Maybe Int
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
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
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
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
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
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
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
| 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
| 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