{-# LANGUAGE DeriveGeneric, CApiFFI #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Dynamically-typed datastructure describing a font, whether resolved or a query.
-- Can be parsed from CSS.
module Graphics.Text.Font.Choose.Pattern(Pattern, Pattern'(..), module M, Binding(..),
        setValue, setValues, getValue, getValues, equalSubset, defaultSubstitute,
        nameParse, nameUnparse, nameFormat, validPattern, validPattern',
        -- For Graphics.Text.Font.Choose.FontSet
        parseFontStretch, parseFontWeight, parseFontFeatures, parseFontVars) where

import Data.Map as M
import Data.MessagePack (MessagePack(..), Object(..))
import Test.QuickCheck (Arbitrary(..), elements)
import Data.Hashable (Hashable(..))
import GHC.Generics (Generic)

import Foreign.C.String (CString)
import Foreign.Ptr (Ptr)
import Control.Exception (throw)
import Graphics.Text.Font.Choose.Internal.FFI (withMessage, fromMessage0, withCString', peekCString')

import Graphics.Text.Font.Choose.Value
import Graphics.Text.Font.Choose.ObjectSet
import Graphics.Text.Font.Choose.Result
import Graphics.Text.Font.Choose.Weight

import Stylist (PropertyParser(..), parseUnorderedShorthand', parseOperands)
import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Data.Text (Text, unpack)
import qualified Data.Text as Txt
import Data.List (intercalate)
import Data.Scientific (toRealFloat)
import Data.Maybe as Mb (listToMaybe, fromMaybe, mapMaybe)
import Data.Char (isAscii)
import Prelude as L

-- | Holds both patterns to match against the available fonts, as well as the information about each font.
type Pattern = M.Map Text [(Binding, Value)]
-- | Wrapper around `Pattern` supporting useful typeclasses.
data Pattern' = Pattern' { Pattern' -> Pattern
unPattern :: Pattern } deriving (Pattern' -> Pattern' -> Bool
(Pattern' -> Pattern' -> Bool)
-> (Pattern' -> Pattern' -> Bool) -> Eq Pattern'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Pattern' -> Pattern' -> Bool
== :: Pattern' -> Pattern' -> Bool
$c/= :: Pattern' -> Pattern' -> Bool
/= :: Pattern' -> Pattern' -> Bool
Eq, ReadPrec [Pattern']
ReadPrec Pattern'
Int -> ReadS Pattern'
ReadS [Pattern']
(Int -> ReadS Pattern')
-> ReadS [Pattern']
-> ReadPrec Pattern'
-> ReadPrec [Pattern']
-> Read Pattern'
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Pattern'
readsPrec :: Int -> ReadS Pattern'
$creadList :: ReadS [Pattern']
readList :: ReadS [Pattern']
$creadPrec :: ReadPrec Pattern'
readPrec :: ReadPrec Pattern'
$creadListPrec :: ReadPrec [Pattern']
readListPrec :: ReadPrec [Pattern']
Read, Int -> Pattern' -> ShowS
[Pattern'] -> ShowS
Pattern' -> [Char]
(Int -> Pattern' -> ShowS)
-> (Pattern' -> [Char]) -> ([Pattern'] -> ShowS) -> Show Pattern'
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pattern' -> ShowS
showsPrec :: Int -> Pattern' -> ShowS
$cshow :: Pattern' -> [Char]
show :: Pattern' -> [Char]
$cshowList :: [Pattern'] -> ShowS
showList :: [Pattern'] -> ShowS
Show, (forall x. Pattern' -> Rep Pattern' x)
-> (forall x. Rep Pattern' x -> Pattern') -> Generic Pattern'
forall x. Rep Pattern' x -> Pattern'
forall x. Pattern' -> Rep Pattern' x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Pattern' -> Rep Pattern' x
from :: forall x. Pattern' -> Rep Pattern' x
$cto :: forall x. Rep Pattern' x -> Pattern'
to :: forall x. Rep Pattern' x -> Pattern'
Generic)
-- | The precedance for a field of a Pattern.
data Binding = Strong | Weak | Same deriving (Binding -> Binding -> Bool
(Binding -> Binding -> Bool)
-> (Binding -> Binding -> Bool) -> Eq Binding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Binding -> Binding -> Bool
== :: Binding -> Binding -> Bool
$c/= :: Binding -> Binding -> Bool
/= :: Binding -> Binding -> Bool
Eq, Eq Binding
Eq Binding
-> (Binding -> Binding -> Ordering)
-> (Binding -> Binding -> Bool)
-> (Binding -> Binding -> Bool)
-> (Binding -> Binding -> Bool)
-> (Binding -> Binding -> Bool)
-> (Binding -> Binding -> Binding)
-> (Binding -> Binding -> Binding)
-> Ord Binding
Binding -> Binding -> Bool
Binding -> Binding -> Ordering
Binding -> Binding -> Binding
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Binding -> Binding -> Ordering
compare :: Binding -> Binding -> Ordering
$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
>= :: Binding -> Binding -> Bool
$cmax :: Binding -> Binding -> Binding
max :: Binding -> Binding -> Binding
$cmin :: Binding -> Binding -> Binding
min :: Binding -> Binding -> Binding
Ord, Int -> Binding
Binding -> Int
Binding -> [Binding]
Binding -> Binding
Binding -> Binding -> [Binding]
Binding -> Binding -> Binding -> [Binding]
(Binding -> Binding)
-> (Binding -> Binding)
-> (Int -> Binding)
-> (Binding -> Int)
-> (Binding -> [Binding])
-> (Binding -> Binding -> [Binding])
-> (Binding -> Binding -> [Binding])
-> (Binding -> Binding -> Binding -> [Binding])
-> Enum Binding
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Binding -> Binding
succ :: Binding -> Binding
$cpred :: Binding -> Binding
pred :: Binding -> Binding
$ctoEnum :: Int -> Binding
toEnum :: Int -> Binding
$cfromEnum :: Binding -> Int
fromEnum :: Binding -> Int
$cenumFrom :: Binding -> [Binding]
enumFrom :: Binding -> [Binding]
$cenumFromThen :: Binding -> Binding -> [Binding]
enumFromThen :: Binding -> Binding -> [Binding]
$cenumFromTo :: Binding -> Binding -> [Binding]
enumFromTo :: Binding -> Binding -> [Binding]
$cenumFromThenTo :: Binding -> Binding -> Binding -> [Binding]
enumFromThenTo :: Binding -> Binding -> Binding -> [Binding]
Enum, ReadPrec [Binding]
ReadPrec Binding
Int -> ReadS Binding
ReadS [Binding]
(Int -> ReadS Binding)
-> ReadS [Binding]
-> ReadPrec Binding
-> ReadPrec [Binding]
-> Read Binding
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Binding
readsPrec :: Int -> ReadS Binding
$creadList :: ReadS [Binding]
readList :: ReadS [Binding]
$creadPrec :: ReadPrec Binding
readPrec :: ReadPrec Binding
$creadListPrec :: ReadPrec [Binding]
readListPrec :: ReadPrec [Binding]
Read, Int -> Binding -> ShowS
[Binding] -> ShowS
Binding -> [Char]
(Int -> Binding -> ShowS)
-> (Binding -> [Char]) -> ([Binding] -> ShowS) -> Show Binding
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Binding -> ShowS
showsPrec :: Int -> Binding -> ShowS
$cshow :: Binding -> [Char]
show :: Binding -> [Char]
$cshowList :: [Binding] -> ShowS
showList :: [Binding] -> ShowS
Show, (forall x. Binding -> Rep Binding x)
-> (forall x. Rep Binding x -> Binding) -> Generic Binding
forall x. Rep Binding x -> Binding
forall x. Binding -> Rep Binding x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Binding -> Rep Binding x
from :: forall x. Binding -> Rep Binding x
$cto :: forall x. Rep Binding x -> Binding
to :: forall x. Rep Binding x -> Binding
Generic)

instance Hashable Binding where
    hash :: Binding -> Int
hash = Binding -> Int
forall a. Enum a => a -> Int
fromEnum
instance MessagePack Binding where
    fromObject :: Object -> Maybe Binding
fromObject (ObjectBool Bool
True) = Binding -> Maybe Binding
forall a. a -> Maybe a
Just Binding
Strong
    fromObject (ObjectBool Bool
False) = Binding -> Maybe Binding
forall a. a -> Maybe a
Just Binding
Weak
    fromObject Object
ObjectNil = Binding -> Maybe Binding
forall a. a -> Maybe a
Just Binding
Same
    fromObject Object
_ = Maybe Binding
forall a. Maybe a
Nothing
    toObject :: Binding -> Object
toObject Binding
Strong = Bool -> Object
ObjectBool Bool
True
    toObject Binding
Weak = Bool -> Object
ObjectBool Bool
False
    toObject Binding
Same = Object
ObjectNil

instance Hashable Pattern' where hash :: Pattern' -> Int
hash = Pattern -> Int
forall a. Hashable a => a -> Int
hash (Pattern -> Int) -> (Pattern' -> Pattern) -> Pattern' -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern' -> Pattern
unPattern
instance MessagePack Pattern' where
    fromObject :: Object -> Maybe Pattern'
fromObject = (Pattern -> Pattern') -> Maybe Pattern -> Maybe Pattern'
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pattern -> Pattern'
Pattern' (Maybe Pattern -> Maybe Pattern')
-> (Object -> Maybe Pattern) -> Object -> Maybe Pattern'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Maybe Pattern
forall a. MessagePack a => Object -> Maybe a
fromObject
    toObject :: Pattern' -> Object
toObject = Pattern -> Object
forall a. MessagePack a => a -> Object
toObject (Pattern -> Object) -> (Pattern' -> Pattern) -> Pattern' -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern' -> Pattern
unPattern

instance Arbitrary Pattern' where
    -- FIXME: Stop enforcing singletons, without incurring too many invalid patterns!
    arbitrary :: Gen Pattern'
arbitrary = Pattern -> Pattern'
Pattern' (Pattern -> Pattern')
-> (Map [Char] [(Binding, Value)] -> Pattern)
-> Map [Char] [(Binding, Value)]
-> Pattern'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> Text) -> Map [Char] [(Binding, Value)] -> Pattern
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys [Char] -> Text
normKey (Map [Char] [(Binding, Value)] -> Pattern')
-> (Map [Char] (Binding, Value) -> Map [Char] [(Binding, Value)])
-> Map [Char] (Binding, Value)
-> Pattern'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Binding, Value) -> [(Binding, Value)])
-> Map [Char] (Binding, Value) -> Map [Char] [(Binding, Value)]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((Binding, Value) -> [(Binding, Value)] -> [(Binding, Value)]
forall a. a -> [a] -> [a]
:[]) (Map [Char] (Binding, Value) -> Pattern')
-> Gen (Map [Char] (Binding, Value)) -> Gen Pattern'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Map [Char] (Binding, Value))
forall a. Arbitrary a => Gen a
arbitrary
        where
            normKey :: [Char] -> Text
normKey = [Char] -> Text
Txt.pack ([Char] -> Text) -> ShowS -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
L.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\0') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
L.map Char -> Char
toAscii ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
L.take Int
17
            toAscii :: Char -> Char
            toAscii :: Char -> Char
toAscii Char
ch = Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
ch Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
128
instance Arbitrary Binding where
    arbitrary :: Gen Binding
arbitrary = [Binding] -> Gen Binding
forall a. HasCallStack => [a] -> Gen a
elements [Binding
Strong, Binding
Weak] -- Same doesn't roundtrip!

-- | Does the pattern hold a value we can process?
validPattern :: Pattern -> Bool
validPattern :: Pattern -> Bool
validPattern Pattern
self = Bool -> Bool
not (Pattern -> Bool
forall k a. Map k a -> Bool
M.null Pattern
self) Bool -> Bool -> Bool
&&
        ((Binding, Value) -> Bool) -> [(Binding, Value)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Value -> Bool
validValue (Value -> Bool)
-> ((Binding, Value) -> Value) -> (Binding, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Binding, Value) -> Value
forall a b. (a, b) -> b
snd) ([[(Binding, Value)]] -> [(Binding, Value)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Binding, Value)]] -> [(Binding, Value)])
-> [[(Binding, Value)]] -> [(Binding, Value)]
forall a b. (a -> b) -> a -> b
$ Pattern -> [[(Binding, Value)]]
forall k a. Map k a -> [a]
M.elems Pattern
self) Bool -> Bool -> Bool
&&
        ([(Binding, Value)] -> Bool) -> [[(Binding, Value)]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool)
-> ([(Binding, Value)] -> Bool) -> [(Binding, Value)] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Binding, Value)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null) (Pattern -> [[(Binding, Value)]]
forall k a. Map k a -> [a]
M.elems Pattern
self) Bool -> Bool -> Bool
&&
        (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Txt.null) (Pattern -> [Text]
forall k a. Map k a -> [k]
M.keys Pattern
self) Bool -> Bool -> Bool
&&
        ((Binding, Value) -> Bool) -> [(Binding, Value)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Binding -> Binding -> Bool
forall a. Eq a => a -> a -> Bool
/= Binding
Same) (Binding -> Bool)
-> ((Binding, Value) -> Binding) -> (Binding, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Binding, Value) -> Binding
forall a b. (a, b) -> a
fst) ([[(Binding, Value)]] -> [(Binding, Value)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Binding, Value)]] -> [(Binding, Value)])
-> [[(Binding, Value)]] -> [(Binding, Value)]
forall a b. (a -> b) -> a -> b
$ Pattern -> [[(Binding, Value)]]
forall k a. Map k a -> [a]
M.elems Pattern
self) Bool -> Bool -> Bool
&&
        (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Bool
Txt.elem Char
'\0') (Pattern -> [Text]
forall k a. Map k a -> [k]
M.keys Pattern
self) Bool -> Bool -> Bool
&&
        (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Char -> Bool) -> Text -> Bool
Txt.all Char -> Bool
isAscii) (Pattern -> [Text]
forall k a. Map k a -> [k]
M.keys Pattern
self) Bool -> Bool -> Bool
&&
        (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Text
k -> Text -> Int
Txt.length Text
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
18) (Pattern -> [Text]
forall k a. Map k a -> [k]
M.keys Pattern
self)
-- | Variant of `validPattern` which applies to the `Pattern'` wrapper.
validPattern' :: Pattern' -> Bool
validPattern' :: Pattern' -> Bool
validPattern' = Pattern -> Bool
validPattern (Pattern -> Bool) -> (Pattern' -> Pattern) -> Pattern' -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern' -> Pattern
unPattern

-- | Replace a field with a singular type-casted value.
setValue :: ToValue v => Text -> Binding -> v -> Pattern -> Pattern
setValue :: forall v. ToValue v => Text -> Binding -> v -> Pattern -> Pattern
setValue Text
key Binding
strength v
v Pattern
self = Text -> Binding -> [v] -> Pattern -> Pattern
forall v. ToValue v => Text -> Binding -> [v] -> Pattern -> Pattern
setValues Text
key Binding
strength [v
v] Pattern
self
-- | Replace a field with multiple type-casted values.
setValues :: ToValue v => Text -> Binding -> [v] -> Pattern -> Pattern
setValues :: forall v. ToValue v => Text -> Binding -> [v] -> Pattern -> Pattern
setValues Text
key Binding
strength [v]
vs Pattern
self = Text -> [(Binding, Value)] -> Pattern -> Pattern
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
key [(Binding
strength, v -> Value
forall x. ToValue x => x -> Value
toValue v
v) | v
v <- [v]
vs] Pattern
self

-- | Retrieve a field's primary type-casted value.
getValue :: ToValue v => Text -> Pattern -> Maybe v
getValue :: forall v. ToValue v => Text -> Pattern -> Maybe v
getValue Text
key Pattern
self = Value -> Maybe v
forall x. ToValue x => Value -> Maybe x
fromValue (Value -> Maybe v)
-> ((Binding, Value) -> Value) -> (Binding, Value) -> Maybe v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Binding, Value) -> Value
forall a b. (a, b) -> b
snd ((Binding, Value) -> Maybe v) -> Maybe (Binding, Value) -> Maybe v
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Binding, Value)] -> Maybe (Binding, Value)
forall a. [a] -> Maybe a
listToMaybe ([(Binding, Value)] -> Maybe (Binding, Value))
-> Maybe [(Binding, Value)] -> Maybe (Binding, Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Pattern -> Maybe [(Binding, Value)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Pattern
self
-- | Retrieve a field's type-casted values.
getValues :: ToValue v => Text -> Pattern -> [v]
getValues :: forall v. ToValue v => Text -> Pattern -> [v]
getValues Text
key Pattern
self = ((Binding, Value) -> Maybe v) -> [(Binding, Value)] -> [v]
forall a b. (a -> Maybe b) -> [a] -> [b]
Mb.mapMaybe (Value -> Maybe v
forall x. ToValue x => Value -> Maybe x
fromValue (Value -> Maybe v)
-> ((Binding, Value) -> Value) -> (Binding, Value) -> Maybe v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Binding, Value) -> Value
forall a b. (a, b) -> b
snd) ([(Binding, Value)] -> [v]) -> [(Binding, Value)] -> [v]
forall a b. (a -> b) -> a -> b
$ [(Binding, Value)]
-> Maybe [(Binding, Value)] -> [(Binding, Value)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(Binding, Value)] -> [(Binding, Value)])
-> Maybe [(Binding, Value)] -> [(Binding, Value)]
forall a b. (a -> b) -> a -> b
$ Text -> Pattern -> Maybe [(Binding, Value)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Pattern
self

-- | Returns whether the given patterns have exactly the same values for all of the given objects.
equalSubset :: Pattern -> Pattern -> ObjectSet -> Bool
equalSubset :: Pattern -> Pattern -> ObjectSet -> Bool
equalSubset Pattern
a Pattern
b ObjectSet
os | Pattern -> Bool
validPattern Pattern
a Bool -> Bool -> Bool
&& Pattern -> Bool
validPattern Pattern
b =
    case (CString -> Int -> Int) -> [Object] -> Int
forall a b. MessagePack a => (CString -> Int -> b) -> a -> b
withMessage CString -> Int -> Int
fcPatternEqualSubset [Pattern -> Object
forall a. MessagePack a => a -> Object
toObject Pattern
a, Pattern -> Object
forall a. MessagePack a => a -> Object
toObject Pattern
b, ObjectSet -> Object
forall a. MessagePack a => a -> Object
toObject ObjectSet
os] of
        Int
0 -> Bool
False
        Int
1 -> Bool
True
        Int
_ -> FcException -> Bool
forall a e. Exception e => e -> a
throw FcException
ErrOOM
  | Bool
otherwise = Bool
False

foreign import capi "fontconfig-wrap.h" fcPatternEqualSubset :: CString -> Int -> Int

-- | 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
a | Pattern -> Bool
validPattern Pattern
a = (Ptr Int -> CString) -> Pattern
forall a. MessagePack a => (Ptr Int -> CString) -> a
fromMessage0 ((Ptr Int -> CString) -> Pattern)
-> (Ptr Int -> CString) -> Pattern
forall a b. (a -> b) -> a -> b
$ (CString -> Int -> Ptr Int -> CString)
-> Pattern -> Ptr Int -> CString
forall a b. MessagePack a => (CString -> Int -> b) -> a -> b
withMessage CString -> Int -> Ptr Int -> CString
fcDefaultSubstitute Pattern
a
    | Bool
otherwise = Pattern
a

foreign import capi "fontconfig-wrap.h" fcDefaultSubstitute :: CString -> Int -> Ptr Int -> CString

-- | Converts name from the standard text format described above into a pattern.
nameParse :: String -> Pattern
nameParse :: [Char] -> Pattern
nameParse = (Ptr Int -> CString) -> Pattern
forall a. MessagePack a => (Ptr Int -> CString) -> a
fromMessage0 ((Ptr Int -> CString) -> Pattern)
-> ([Char] -> Ptr Int -> CString) -> [Char] -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CString -> Ptr Int -> CString) -> [Char] -> Ptr Int -> CString
forall a. (CString -> a) -> [Char] -> a
withCString' CString -> Ptr Int -> CString
fcNameParse

foreign import capi "fontconfig-wrap.h" fcNameParse :: CString -> Ptr Int -> CString

-- | Converts the given pattern into the standard text format described above.
nameUnparse :: Pattern -> String
nameUnparse :: Pattern -> [Char]
nameUnparse Pattern
a | Pattern -> Bool
validPattern Pattern
a = CString -> [Char]
peekCString' (CString -> [Char]) -> CString -> [Char]
forall a b. (a -> b) -> a -> b
$ (CString -> Int -> CString) -> Pattern -> CString
forall a b. MessagePack a => (CString -> Int -> b) -> a -> b
withMessage CString -> Int -> CString
fcNameUnparse Pattern
a
    | Bool
otherwise = [Char]
""

foreign import capi "fontconfig-wrap.h" fcNameUnparse :: CString -> Int -> CString

-- | Format a pattern into a string according to a format specifier
-- See https://fontconfig.pages.freedesktop.org/fontconfig/fontconfig-devel/fcpatternformat.html for full details.
nameFormat :: Pattern -> String -> String
nameFormat :: Pattern -> ShowS
nameFormat Pattern
a [Char]
b
    | Pattern -> Bool
validPattern Pattern
a = CString -> [Char]
peekCString' (CString -> [Char]) -> CString -> [Char]
forall a b. (a -> b) -> a -> b
$ ((CString -> CString) -> [Char] -> CString)
-> [Char] -> (CString -> CString) -> CString
forall a b c. (a -> b -> c) -> b -> a -> c
flip (CString -> CString) -> [Char] -> CString
forall a. (CString -> a) -> [Char] -> a
withCString' [Char]
b ((CString -> CString) -> CString)
-> (CString -> CString) -> CString
forall a b. (a -> b) -> a -> b
$ (CString -> Int -> CString -> CString)
-> Pattern -> CString -> CString
forall a b. MessagePack a => (CString -> Int -> b) -> a -> b
withMessage CString -> Int -> CString -> CString
fcNameFormat Pattern
a
    | Bool
otherwise = [Char]
""

foreign import capi "fontconfig-wrap.h" fcNameFormat :: CString -> Int -> CString -> CString

------
--- CSS
------

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

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

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

parseLength :: Double -> NumericValue -> Text -> Double
parseLength :: Double -> NumericValue -> Text -> Double
parseLength Double
super NumericValue
len Text
unit = Double -> Text -> Double
convert (NumericValue -> Double
nv2double NumericValue
len) Text
unit
  where
    convert :: Double -> Text -> Double
convert = Double -> Text -> Double
forall {t}. (Eq t, IsString t) => Double -> t -> Double
c
    c :: Double -> t -> Double
c Double
x t
"pt" = Double
x -- Unit FontConfig expects!
    c Double
x t
"pc" = (Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
6) Double -> t -> Double
`c` t
"in"
    c Double
x t
"in" = (Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
72) Double -> t -> Double
`c` t
"pt"
    c Double
x t
"Q" = (Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
40) Double -> t -> Double
`c` t
"cm"
    c Double
x t
"mm" = (Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
10) Double -> t -> Double
`c` t
"cm"
    c Double
x t
"cm" = (Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2.54) Double -> t -> Double
`c` t
"in"
    c Double
x t
"px" = (Double
xDouble -> Double -> Double
forall 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 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
super
    c Double
x t
"%" = (Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
100) Double -> t -> Double
`c` t
"em"
    c Double
_ t
_ = Double
0Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0 -- NaN

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

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

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

sets :: ToValue v => Text -> Binding -> [v] -> Pattern -> Maybe Pattern
sets :: forall v.
ToValue v =>
Text -> Binding -> [v] -> Pattern -> Maybe Pattern
sets Text
a Binding
b [v]
c Pattern
d = Pattern -> Maybe Pattern
forall a. a -> Maybe a
Just (Pattern -> Maybe Pattern) -> Pattern -> Maybe Pattern
forall a b. (a -> b) -> a -> b
$ Text -> Binding -> [v] -> Pattern -> Pattern
forall v. ToValue v => Text -> Binding -> [v] -> Pattern -> Pattern
setValues Text
a Binding
b [v]
c Pattern
d
set :: ToValue v => Text -> Binding -> v -> Pattern -> Maybe Pattern
set :: forall v.
ToValue v =>
Text -> Binding -> v -> Pattern -> Maybe Pattern
set Text
a Binding
b v
c Pattern
d = Pattern -> Maybe Pattern
forall a. a -> Maybe a
Just (Pattern -> Maybe Pattern) -> Pattern -> Maybe Pattern
forall a b. (a -> b) -> a -> b
$ Text -> Binding -> v -> Pattern -> Pattern
forall v. ToValue v => Text -> Binding -> v -> Pattern -> Pattern
setValue Text
a Binding
b v
c Pattern
d
seti :: Text -> Binding -> Int -> Pattern -> Maybe Pattern
seti :: Text -> Binding -> Int -> Pattern -> Maybe Pattern
seti Text
a Binding
b Int
c Pattern
d = Pattern -> Maybe Pattern
forall a. a -> Maybe a
Just (Pattern -> Maybe Pattern) -> Pattern -> Maybe Pattern
forall a b. (a -> b) -> a -> b
$ Text -> Binding -> Int -> Pattern -> Pattern
forall v. ToValue v => Text -> Binding -> v -> Pattern -> Pattern
setValue Text
a Binding
b (Int
c :: Int) Pattern
d
unset' :: Text -> Pattern -> Maybe Pattern
unset' :: Text -> Pattern -> Maybe Pattern
unset' Text
a Pattern
b = Pattern -> Maybe Pattern
forall a. a -> Maybe a
Just (Pattern -> Maybe Pattern) -> Pattern -> Maybe Pattern
forall a b. (a -> b) -> a -> b
$ Text -> Pattern -> Pattern
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Text
a Pattern
b

getSize :: Pattern -> Double
getSize :: Pattern -> Double
getSize Pattern
pat | Just [(Binding
_, ValueDouble Double
x)] <- Text -> Pattern -> Maybe [(Binding, Value)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"size" Pattern
pat = Double
x
    | Bool
otherwise = Double
10

instance PropertyParser Pattern' where
    temp :: Pattern'
temp = Pattern -> Pattern'
Pattern' Pattern
forall k a. Map k a
M.empty

    longhand :: Pattern' -> Pattern' -> Text -> [Token] -> Maybe Pattern'
longhand Pattern'
_ (Pattern' Pattern
self) Text
"font-family" [Token]
toks
        | (ObjectSet
fonts, Bool
True, []) <- [Token] -> (ObjectSet, Bool, [Token])
parseFontFamily [Token]
toks = Pattern -> Pattern'
Pattern' (Pattern -> Pattern') -> Maybe Pattern -> Maybe Pattern'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Binding -> ObjectSet -> Pattern -> Maybe Pattern
forall v.
ToValue v =>
Text -> Binding -> [v] -> Pattern -> Maybe Pattern
sets Text
"family" Binding
Strong ObjectSet
fonts Pattern
self

    -- font-size: initial should be configurable!
    longhand (Pattern' Pattern
super) (Pattern' 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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
y =
            Pattern -> Pattern'
Pattern' (Pattern -> Pattern') -> Maybe Pattern -> Maybe Pattern'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Binding -> Double -> Pattern -> Maybe Pattern
forall v.
ToValue v =>
Text -> Binding -> v -> Pattern -> Maybe Pattern
set Text
"size" Binding
Strong Double
y Pattern
self
    longhand Pattern'
super Pattern'
self Text
"font-size" [Percentage Text
x NumericValue
y] =
        Pattern' -> Pattern' -> Text -> [Token] -> Maybe Pattern'
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
"%"]
    -- NOTE: Approximate implementation, caller should supply a real one!
    longhand (Pattern' Pattern
super) (Pattern' Pattern
self) Text
"font-size" [Ident Text
x] =
        let y :: Double
y = Double
10 :: Double in Pattern -> Pattern'
Pattern' (Pattern -> Pattern') -> Maybe Pattern -> Maybe Pattern'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Text
x of
            -- NOTE: If a caller wants to be more precise about the base size (a.k.a `y`)
            -- they should parse it themselves!
            Text
"xx-small" -> Text -> Binding -> Double -> Pattern -> Maybe Pattern
forall v.
ToValue v =>
Text -> Binding -> v -> Pattern -> Maybe Pattern
set Text
"size" Binding
Strong (Double
3Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
5Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
y) Pattern
self
            Text
"x-small" -> Text -> Binding -> Double -> Pattern -> Maybe Pattern
forall v.
ToValue v =>
Text -> Binding -> v -> Pattern -> Maybe Pattern
set Text
"size" Binding
Strong (Double
3Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
4Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
y) Pattern
self
            Text
"small" -> Text -> Binding -> Double -> Pattern -> Maybe Pattern
forall v.
ToValue v =>
Text -> Binding -> v -> Pattern -> Maybe Pattern
set Text
"size" Binding
Strong (Double
8Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
9Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
y) Pattern
self
            Text
"medium" -> Text -> Binding -> Double -> Pattern -> Maybe Pattern
forall v.
ToValue v =>
Text -> Binding -> v -> Pattern -> Maybe Pattern
set Text
"size" Binding
Strong Double
y Pattern
self
            Text
"large" -> Text -> Binding -> Double -> Pattern -> Maybe Pattern
forall v.
ToValue v =>
Text -> Binding -> v -> Pattern -> Maybe Pattern
set Text
"size" Binding
Strong (Double
6Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
5Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
y) Pattern
self
            Text
"x-large" -> Text -> Binding -> Double -> Pattern -> Maybe Pattern
forall v.
ToValue v =>
Text -> Binding -> v -> Pattern -> Maybe Pattern
set Text
"size" Binding
Strong (Double
3Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
y) Pattern
self
            Text
"xx-large" -> Text -> Binding -> Double -> Pattern -> Maybe Pattern
forall v.
ToValue v =>
Text -> Binding -> v -> Pattern -> Maybe Pattern
set Text
"size" Binding
Strong (Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
y) Pattern
self
            Text
"xxx-large" -> Text -> Binding -> Double -> Pattern -> Maybe Pattern
forall v.
ToValue v =>
Text -> Binding -> v -> Pattern -> Maybe Pattern
set Text
"size" Binding
Strong (Double
3Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
y) Pattern
self
            -- NOTE: Spec encourages a more complex formula, caller should implement!
            Text
"smaller" -> Text -> Binding -> Double -> Pattern -> Maybe Pattern
forall v.
ToValue v =>
Text -> Binding -> v -> Pattern -> Maybe Pattern
set Text
"size" Binding
Strong (Pattern -> Double
getSize Pattern
superDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
1.2) Pattern
self
            Text
"larger" -> Text -> Binding -> Double -> Pattern -> Maybe Pattern
forall v.
ToValue v =>
Text -> Binding -> v -> Pattern -> Maybe Pattern
set Text
"size" Binding
Strong (Pattern -> Double
getSize Pattern
superDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
1.2) Pattern
self
            Text
_ -> Maybe Pattern
forall a. Maybe a
Nothing

    longhand Pattern'
_ (Pattern' Pattern
self) Text
"font-style" [Ident Text
"initial"] = Pattern -> Pattern'
Pattern' (Pattern -> Pattern') -> Maybe Pattern -> Maybe Pattern'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Binding -> Int -> Pattern -> Maybe Pattern
seti Text
"slant" Binding
Strong Int
0 Pattern
self
    longhand Pattern'
_ (Pattern' Pattern
self) Text
"font-style" [Ident Text
"normal"] = Pattern -> Pattern'
Pattern' (Pattern -> Pattern') -> Maybe Pattern -> Maybe Pattern'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Binding -> Int -> Pattern -> Maybe Pattern
seti Text
"slant" Binding
Strong Int
0 Pattern
self
    longhand Pattern'
_ (Pattern' Pattern
self) Text
"font-style" [Ident Text
"italic"] = Pattern -> Pattern'
Pattern' (Pattern -> Pattern') -> Maybe Pattern -> Maybe Pattern'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Binding -> Int -> Pattern -> Maybe Pattern
seti Text
"slant" Binding
Strong Int
100 Pattern
self
    longhand Pattern'
_ (Pattern' Pattern
self) Text
"font-style" [Ident Text
"oblique"] = Pattern -> Pattern'
Pattern' (Pattern -> Pattern') -> Maybe Pattern -> Maybe Pattern'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Binding -> Int -> Pattern -> Maybe Pattern
seti Text
"slant" Binding
Strong Int
110 Pattern
self
    longhand Pattern'
_ (Pattern' Pattern
self) Text
"font-style" [Ident Text
"oblique", Dimension Text
_ NumericValue
_ Text
unit]
        | Text
unit Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Text -> [Text]
Txt.words Text
"deg grad rad turn" = Pattern -> Pattern'
Pattern' (Pattern -> Pattern') -> Maybe Pattern -> Maybe Pattern'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Binding -> Int -> Pattern -> Maybe Pattern
seti Text
"slant" Binding
Strong Int
110 Pattern
self

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

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

    longhand Pattern'
_ (Pattern' Pattern
self) Text
"font-variation-settings" [Ident Text
k]
        | Text
k Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"initial", Text
"normal"] = Pattern -> Pattern'
Pattern' (Pattern -> Pattern') -> Maybe Pattern -> Maybe Pattern'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Pattern -> Maybe Pattern
unset' Text
"variable" Pattern
self
    longhand Pattern'
_ (Pattern' Pattern
self) Text
"font-variation-settings" [Token]
toks
        | ([([Char], Double)]
vars , Bool
True, []) <- [Token] -> ([([Char], Double)], Bool, [Token])
parseFontVars [Token]
toks =
            Pattern -> Pattern'
Pattern' (Pattern -> Pattern') -> Maybe Pattern -> Maybe Pattern'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Binding -> Bool -> Pattern -> Maybe Pattern
forall v.
ToValue v =>
Text -> Binding -> v -> Pattern -> Maybe Pattern
set Text
"variable" Binding
Strong Bool
True (Pattern -> Maybe Pattern) -> Maybe Pattern -> Maybe Pattern
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                Text -> Binding -> [Char] -> Pattern -> Maybe Pattern
forall v.
ToValue v =>
Text -> Binding -> v -> Pattern -> Maybe Pattern
set Text
"fontvariations" Binding
Strong ([Char] -> ObjectSet -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," (ObjectSet -> [Char]) -> ObjectSet -> [Char]
forall a b. (a -> b) -> a -> b
$ (([Char], Double) -> [Char]) -> [([Char], Double)] -> ObjectSet
forall a b. (a -> b) -> [a] -> [b]
L.map ([Char], Double) -> [Char]
forall a b. (a, b) -> a
fst [([Char], Double)]
vars) Pattern
self)

    longhand Pattern'
_ (Pattern' Pattern
s) Text
"font-stretch" [Token
tok]
        | Just Int
x <- Token -> Maybe Int
parseFontStretch Token
tok = Pattern -> Pattern'
Pattern' (Pattern -> Pattern') -> Maybe Pattern -> Maybe Pattern'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Binding -> Int -> Pattern -> Maybe Pattern
seti Text
"width" Binding
Strong Int
x Pattern
s

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

    shorthand :: Pattern' -> Text -> [Token] -> Props
shorthand Pattern'
self Text
"font" [Token]
toks = case [Token] -> [[Token]]
parseOperands [Token]
toks of
        ([Token]
a:[Token]
b:[Token]
c:[Token]
d:[[Token]]
toks') | ret :: Props
ret@((Text, [Token])
_:Props
_) <- [[Token]] -> Props
unordered [[Token]
a,[Token]
b,[Token]
c,[Token]
d] -> Props -> [[Token]] -> Props
forall {a}.
IsString a =>
[(a, [Token])] -> [[Token]] -> [(a, [Token])]
inner Props
ret [[Token]]
toks'
        ([Token]
a:[Token]
b:[Token]
c:[[Token]]
toks') | ret :: Props
ret@((Text, [Token])
_:Props
_) <- [[Token]] -> Props
unordered [[Token]
a,[Token]
b,[Token]
c] -> Props -> [[Token]] -> Props
forall {a}.
IsString a =>
[(a, [Token])] -> [[Token]] -> [(a, [Token])]
inner Props
ret [[Token]]
toks'
        ([Token]
a:[Token]
b:[[Token]]
toks') | ret :: Props
ret@((Text, [Token])
_:Props
_) <- [[Token]] -> Props
unordered [[Token]
a,[Token]
b] -> Props -> [[Token]] -> Props
forall {a}.
IsString a =>
[(a, [Token])] -> [[Token]] -> [(a, [Token])]
inner Props
ret [[Token]]
toks'
        ([Token]
a:[[Token]]
toks') | ret :: Props
ret@((Text, [Token])
_:Props
_) <- [[Token]] -> Props
unordered [[Token]
a] -> Props -> [[Token]] -> Props
forall {a}.
IsString a =>
[(a, [Token])] -> [[Token]] -> [(a, [Token])]
inner Props
ret [[Token]]
toks'
        [[Token]]
toks' -> Props -> [[Token]] -> Props
forall {a}.
IsString a =>
[(a, [Token])] -> [[Token]] -> [(a, [Token])]
inner [] [[Token]]
toks'
      where
        unordered :: [[Token]] -> Props
unordered [[Token]]
operands =
          let ret :: Props
ret = Pattern' -> [Text] -> [[Token]] -> Props
forall a. PropertyParser a => a -> [Text] -> [[Token]] -> Props
parseUnorderedShorthand' Pattern'
self [
                        Text
"font-style", Text
"font-variant", Text
"font-weight", Text
"font-stretch"
                    ] [[Token]]
operands
          in if (Text
"", []) (Text, [Token]) -> Props -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Props
ret then [] else Props
ret -- Check for errors!
        inner :: [(a, [Token])] -> [[Token]] -> [(a, [Token])]
inner [(a, [Token])]
ret ([Token]
sz:[Delim Char
'/']:[Token]
height:[[Token]]
family)
            | Just Pattern'
_ <- Pattern' -> Pattern' -> Text -> [Token] -> Maybe Pattern'
forall a. PropertyParser a => a -> a -> Text -> [Token] -> Maybe a
longhand Pattern'
self Pattern'
self Text
"font-size" [Token]
sz,
              Just Pattern'
_ <- Pattern' -> Pattern' -> Text -> [Token] -> Maybe Pattern'
forall a. PropertyParser a => a -> a -> Text -> [Token] -> Maybe a
longhand Pattern'
self Pattern'
self Text
"line-height" [Token]
height,
              Just Pattern'
_ <- Pattern' -> Pattern' -> Text -> [Token] -> Maybe Pattern'
forall a. PropertyParser a => a -> a -> Text -> [Token] -> Maybe a
longhand Pattern'
self Pattern'
self Text
"font-family" ([Token] -> Maybe Pattern') -> [Token] -> Maybe Pattern'
forall a b. (a -> b) -> a -> b
$ [[Token]] -> [Token]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Token]]
family =
                (a
"font-size", [Token]
sz)(a, [Token]) -> [(a, [Token])] -> [(a, [Token])]
forall a. a -> [a] -> [a]
:(a
"line-height", [Token]
height)(a, [Token]) -> [(a, [Token])] -> [(a, [Token])]
forall a. a -> [a] -> [a]
:
                    (a
"font-family", [[Token]] -> [Token]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Token]]
family)(a, [Token]) -> [(a, [Token])] -> [(a, [Token])]
forall a. a -> [a] -> [a]
:[(a, [Token])]
ret
            | Bool
otherwise = []
        inner [(a, [Token])]
ret ([Token]
sz:[[Token]]
family)
            | Just Pattern'
_ <- Pattern' -> Pattern' -> Text -> [Token] -> Maybe Pattern'
forall a. PropertyParser a => a -> a -> Text -> [Token] -> Maybe a
longhand Pattern'
self Pattern'
self Text
"font-size" [Token]
sz,
              Just Pattern'
_ <- Pattern' -> Pattern' -> Text -> [Token] -> Maybe Pattern'
forall a. PropertyParser a => a -> a -> Text -> [Token] -> Maybe a
longhand Pattern'
self Pattern'
self Text
"font-family" ([Token] -> Maybe Pattern') -> [Token] -> Maybe Pattern'
forall a b. (a -> b) -> a -> b
$ [[Token]] -> [Token]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Token]]
family =
                (a
"font-size", [Token]
sz)(a, [Token]) -> [(a, [Token])] -> [(a, [Token])]
forall a. a -> [a] -> [a]
:(a
"line-height", [Text -> Token
Ident Text
"initial"])(a, [Token]) -> [(a, [Token])] -> [(a, [Token])]
forall a. a -> [a] -> [a]
:
                    (a
"font-family", [[Token]] -> [Token]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Token]]
family)(a, [Token]) -> [(a, [Token])] -> [(a, [Token])]
forall a. a -> [a] -> [a]
:[(a, [Token])]
ret
            | Bool
otherwise = []
        inner [(a, [Token])]
_ [[Token]]
_ = []

    shorthand Pattern'
self Text
k [Token]
v | Just Pattern'
_ <- Pattern' -> Pattern' -> Text -> [Token] -> Maybe Pattern'
forall a. PropertyParser a => a -> a -> Text -> [Token] -> Maybe a
longhand Pattern'
self Pattern'
self Text
k [Token]
v = [(Text
k, [Token]
v)]
        | Bool
otherwise = []