{-# 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)
import System.IO.Unsafe (unsafePerformIO)
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 (Eq, Ord, Enum, Show, Generic)
instance Hashable Binding where
hash Strong = 0
hash Weak = 1
hash Same = 2
setValue :: ToValue x => String -> Binding -> x -> Pattern -> Pattern
setValue key b value pat = (key, [(b, toValue value)]):unset key pat
setValues :: ToValue x => String -> Binding -> [x] -> Pattern -> Pattern
setValues key b values pat = (key, [(b, toValue v) | v <- values]):unset key pat
getValues :: String -> Pattern -> [Value]
getValues key pat | Just ret <- lookup key pat = map snd ret
| otherwise = []
getValues' key pat = mapMaybe fromValue $ getValues key pat
getValue :: String -> Pattern -> Value
getValue key pat | Just ((_, ret):_) <- lookup key pat = ret
| otherwise = ValueVoid
getValue' :: ToValue x => String -> Pattern -> Maybe x
getValue' key pat = fromValue $ getValue key pat
getValue0 :: ToValue x => String -> Pattern -> x
getValue0 key pat = fromValue' $ getValue key pat
unset key mapping = [(key', val') | (key', val') <- mapping, key' /= key]
normalizePattern :: Pattern -> Pattern
normalizePattern pat =
[(key, [val | (key', vals) <- pat, key' == key, val <- vals]) | key <- nub $ map fst pat]
equalSubset :: Pattern -> Pattern -> ObjectSet -> Bool
equalSubset a b objs = unsafePerformIO $ withPattern a $ \a' -> withPattern b $ \b' ->
withObjectSet objs $ fcPatternEqualSubset a' b'
foreign import ccall "FcPatternEqualSubset" fcPatternEqualSubset ::
Pattern_ -> Pattern_ -> ObjectSet_ -> IO Bool
filter :: Pattern -> ObjectSet -> Pattern
filter pat objs =
unsafePerformIO $ withPattern pat $ \pat' -> withObjectSet objs $ \objs' ->
thawPattern_ $ fcPatternFilter pat' objs'
foreign import ccall "FcPatternFilter" fcPatternFilter ::
Pattern_ -> ObjectSet_ -> IO Pattern_
defaultSubstitute :: Pattern -> Pattern
defaultSubstitute pat = unsafePerformIO $ withPattern pat $ \pat' -> do
ret <- fcDefaultSubstitute pat'
thawPattern pat'
foreign import ccall "FcDefaultSubstitute" fcDefaultSubstitute :: Pattern_ -> IO ()
nameParse :: String -> Pattern
nameParse name = unsafePerformIO $ withCString name $ \name' ->
thawPattern_ $ fcNameParse name'
foreign import ccall "FcNameParse" fcNameParse :: CString -> IO Pattern_
nameUnparse :: Pattern -> String
nameUnparse pat = unsafePerformIO $ withPattern pat $ \pat' ->
bracket (throwNull <$> fcNameUnparse pat') free peekCString
foreign import ccall "FcNameUnparse" fcNameUnparse :: Pattern_ -> IO CString
format :: Pattern -> String -> String
format pat fmt =
unsafePerformIO $ withPattern pat $ \pat' -> withCString fmt $ \fmt' -> do
bracket (throwNull <$> fcPatternFormat pat' fmt') free peekCString
foreign import ccall "FcPatternFormat" fcPatternFormat ::
Pattern_ -> CString -> IO CString
data Pattern'
type Pattern_ = Ptr Pattern'
withPattern :: Pattern -> (Pattern_ -> IO a) -> IO a
withPattern pat cb = withNewPattern $ \pat' -> do
forM pat $ \(obj, vals) -> withCString obj $ \obj' -> do
forM vals $ \(strength, val) -> throwFalse <$> withValue val
(fcPatternAdd_ pat' obj' (strength == Strong) True)
cb pat'
foreign import ccall "my_FcPatternAdd" fcPatternAdd_ ::
Pattern_ -> CString -> Bool -> Bool -> Value_ -> IO Bool
patternAsPointer :: Pattern -> IO Pattern_
patternAsPointer = flip withPattern $ \ret -> do
fcPatternReference ret
return 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 pat' = allocaBytes patIter'Size $ \iter' -> do
fcPatternIterStart pat' iter'
ret <- go iter'
return $ normalizePattern ret
where
go :: PatternIter_ -> IO Pattern
go iter' = do
ok <- fcPatternIterIsValid pat' iter'
if ok then do
x <- thawPattern' pat' iter'
ok' <- fcPatternIterNext pat' iter'
xs <- if ok' then go iter' else return []
return (x : xs)
else 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' pat' iter' = do
obj <- peekCString =<< throwNull <$> fcPatternIterGetObject pat' iter'
count <- fcPatternIterValueCount pat' iter'
values <- forM [0..pred count] $ \i ->
allocaBytes value'Size $ \val' -> alloca $ \binding' -> do
res <- fcPatternIterGetValue pat' iter' i val' binding'
throwInt res $ do
binding <- peek binding'
val' <- thawValue val'
return $ case val' of
Just val | binding >= 0 && binding <= 2 -> Just (toEnum binding, val)
Just val -> Just (Same, val)
Nothing -> Nothing
return (obj, catMaybes $ map join 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_ cb = bracket (throwNull <$> cb) fcPatternDestroy thawPattern
withNewPattern cb = bracket (throwNull <$> fcPatternCreate) fcPatternDestroy cb
foreign import ccall "FcPatternCreate" fcPatternCreate :: IO Pattern_
foreign import ccall "FcPatternDestroy" fcPatternDestroy :: Pattern_ -> IO ()
parseFontFamily :: [Token] -> ([String], Bool, [Token])
parseFontFamily (String font:Comma:tail) = let (fonts, b, tail') = parseFontFamily tail
in (unpack font:fonts, b, tail')
parseFontFamily (Ident font:Comma:tail) = let (fonts, b, tail') = parseFontFamily tail
in (unpack font:fonts, b, tail')
parseFontFamily (String font:tail) = ([unpack font], True, tail)
parseFontFamily (Ident font:tail) = ([unpack font], True, tail)
parseFontFamily toks = ([], False, toks)
parseFontFeatures :: [Token] -> ([(String, Int)], Bool, [Token])
parseFontFeatures (String feat:toks) | feature@(_:_:_:_:[]) <- unpack feat = case toks of
Comma:tail -> let (feats, b, tail') = parseFontFeatures tail in ((feature, 1):feats, b, tail')
Ident "on":Comma:tail -> let (f, b, t) = parseFontFeatures tail in ((feature, 1):f, b, t)
Ident "on":tail -> ([(feature, 1)], True, tail)
Ident "off":Comma:tail -> let (f, b, t) = parseFontFeatures tail in ((feature, 1):f, b, t)
Ident "off":tail -> ([(feature, 1)], True, tail)
Number _ (NVInteger x):Comma:tail ->
let (feats, b, tail') = parseFontFeatures tail in ((feature, fromEnum x):feats, b, tail')
Number _ (NVInteger x):tail -> ([(feature, fromEnum x)], True, tail)
parseFontFeatures toks = ([], False, toks)
parseFontVars :: [Token] -> ([(String, Double)], Bool, [Token])
parseFontVars (String var':Number _ x:Comma:tail) | var@(_:_:_:_:[]) <- unpack var' =
let (vars, b, tail') = parseFontVars tail in ((var, nv2double x):vars, b, tail')
parseFontVars (String var':Number _ x:tail) | var@(_:_:_:_:[]) <- unpack var' =
([(var, nv2double x)], True, tail)
parseFontVars toks = ([], False, toks)
parseLength :: Double -> NumericValue -> Text -> Double
parseLength super length unit = convert (nv2double length) unit
where
convert = c
c x "pt" = x
c x "pc" = x/6 `c` "in"
c x "in" = x/72 `c` "pt"
c x "Q" = x/40 `c` "cm"
c x "mm" = x/10 `c` "cm"
c x "cm" = x/2.54 `c` "in"
c x "px" = x/96 `c` "in"
c x "em" = x * super
c x "%" = x/100 `c` "em"
c _ _ = 0/0
parseFontStretch :: Token -> Maybe Int
parseFontStretch (Percentage _ x) = Just $ fromEnum $ nv2double x
parseFontStretch (Ident "ultra-condensed") = Just 50
parseFontStretch (Ident "extra-condensed") = Just 63
parseFontStretch (Ident "condensed") = Just 75
parseFontStretch (Ident "semi-condensed") = Just 88
parseFontStretch (Ident "normal") = Just 100
parseFontStretch (Ident "initial") = Just 100
parseFontStretch (Ident "semi-expanded") = Just 112
parseFontStretch (Ident "expanded") = Just 125
parseFontStretch (Ident "extra-expanded") = Just 150
parseFontStretch (Ident "ultra-expanded") = Just 200
parseFontStretch _ = Nothing
parseFontWeight :: Token -> Maybe Int
parseFontWeight (Ident k) | k `elem` ["initial", "normal"] = Just 80
parseFontWeight (Ident "bold") = Just 200
parseFontWeight (Number _ (NVInteger x)) = Just $ weightFromOpenType $ fromEnum x
parseFontWeight _ = Nothing
nv2double (NVInteger x) = fromInteger x
nv2double (NVNumber x) = toRealFloat x
sets a b c d = Just $ setValues a b c d
set a b c d = Just $ setValue a b c d
seti a b c d = Just $ setValue a b (c :: Int) d
unset' a b = Just $ unset a b
getSize pat | ValueDouble x <- getValue "size" pat = x
| otherwise = 10
instance PropertyParser Pattern where
temp = []
longhand _ self "font-family" toks
| (fonts, True, []) <- parseFontFamily toks = sets "family" Strong fonts self
longhand super self "font-size" [Dimension _ x unit]
| let y = parseLength (getSize super) x unit, not $ isNaN y =
set "size" Strong y self
longhand super self "font-size" [Percentage x y] =
longhand super self "font-size" [Dimension x y "%"]
longhand _ self "font-style" [Ident "initial"] = seti "slant" Strong 0 self
longhand _ self "font-style" [Ident "normal"] = seti "slant" Strong 0 self
longhand _ self "font-style" [Ident "italic"] = seti "slant" Strong 100 self
longhand _ self "font-style" [Ident "oblique"] = seti "slant" Strong 110 self
longhand _ self "font-weight" [tok]
| Just x <- parseFontWeight tok = seti "weight" Strong x self
longhand super self "font-weight" [Number _ (NVInteger x)]
| x > 920 = longhand super self "font-weight" [Number "" $ NVInteger 950]
| otherwise = longhand super self "font-weight" [Number "" $ NVInteger $ (x `div` 100) * 100]
longhand _ self "font-weight" [Ident "lighter"]
| ValueInt x <- getValue "weight" self, x > 200 = seti "weight" Strong 200 self
| ValueInt x <- getValue "weight" self = seti "weight" Strong (max (x - 100) 0) self
| otherwise = seti "weight" Strong 0 self
longhand _ self "font-weight" [Ident "bolder"]
| ValueInt x <- getValue "weight" self, x <= 65 = seti "weight" Strong 80 self
| ValueInt x <- getValue "weight" self, x <= 150 = seti "weight" Strong 200 self
| ValueInt x <- getValue "weight" self, x < 210 = seti "weight" Strong 210 self
| ValueInt _ <- getValue "weight" self = Just self
| otherwise = seti "weight" Strong 200 self
longhand _ self "font-feature-settings" [Ident k]
| k `elem` ["initial", "normal"] = unset' "fontfeatures" self
longhand _ self "font-feature-settings" toks
| (features, True, []) <- parseFontFeatures toks =
set "fontfeatures" Strong (intercalate "," $ map fst features) self
longhand _ self "font-variation-settings" [Ident k]
| k `elem` ["initial", "normal"] = unset' "variable" self
longhand _ self "font-variation-settings" toks
| (_, True, []) <- parseFontVars toks = set "variable" Strong True self
longhand _ s "font-stretch" [tok]
| Just x <- parseFontStretch tok = seti "width" Strong x s
longhand _ _ _ _ = Nothing